From aae57c30b101f830ee23dcf6eb06ee27c6a6b8b0 Mon Sep 17 00:00:00 2001 From: Jose Alves Date: Wed, 8 Jan 2025 21:53:33 +0100 Subject: [PATCH] merge lapack auxiliaries --- legacy/refactor_blaslapack_subm.py | 8 +- src/CMakeLists.txt | 3 +- ...ters.fypp => stdlib_lapack_auxiliary.fypp} | 298 ++++++++++++++++- .../stdlib_lapack_auxiliary_others.fypp | 303 ------------------ 4 files changed, 300 insertions(+), 312 deletions(-) rename src/lapack/{stdlib_lapack_auxiliary_parameters.fypp => stdlib_lapack_auxiliary.fypp} (73%) delete mode 100644 src/lapack/stdlib_lapack_auxiliary_others.fypp diff --git a/legacy/refactor_blaslapack_subm.py b/legacy/refactor_blaslapack_subm.py index 9713549ce..5eef73120 100644 --- a/legacy/refactor_blaslapack_subm.py +++ b/legacy/refactor_blaslapack_subm.py @@ -27,11 +27,9 @@ # Define the LAPACK routine groups lapack_groups = { - "auxiliary_parameters": [ + "auxiliary": [ "lamch", "lamc3", "labad", "csum1", "zsum1", - "laqsb" - ], - "auxiliary_others": [ + "laqsb", "ladiv1","ladiv2", "rot" ], @@ -252,7 +250,7 @@ lapack_subgroups = { "base" : { "dependencies" : [], - "members" : ["auxiliary_parameters","auxiliary_others","blas_like_base", + "members" : ["auxiliary","blas_like_base", "blas_like_scalar","blas_like_l1","blas_like_l2","blas_like_l3","blas_like_mnorm", "givens_jacobi_rot","householder_reflectors"], }, diff --git a/src/CMakeLists.txt b/src/CMakeLists.txt index 780c8f65c..a0a7ad913 100644 --- a/src/CMakeLists.txt +++ b/src/CMakeLists.txt @@ -105,8 +105,7 @@ set(cppFiles lapack/stdlib_lapack_eig_svd_lsq.fypp lapack/stdlib_linalg_lapack_aux.fypp - lapack/stdlib_lapack_auxiliary_others.fypp - lapack/stdlib_lapack_auxiliary_parameters.fypp + lapack/stdlib_lapack_auxiliary.fypp lapack/stdlib_lapack_blas_like_base.fypp lapack/stdlib_lapack_blas_like_l1.fypp lapack/stdlib_lapack_blas_like_l2.fypp diff --git a/src/lapack/stdlib_lapack_auxiliary_parameters.fypp b/src/lapack/stdlib_lapack_auxiliary.fypp similarity index 73% rename from src/lapack/stdlib_lapack_auxiliary_parameters.fypp rename to src/lapack/stdlib_lapack_auxiliary.fypp index 25a12f643..79bcf0214 100644 --- a/src/lapack/stdlib_lapack_auxiliary_parameters.fypp +++ b/src/lapack/stdlib_lapack_auxiliary.fypp @@ -1,5 +1,5 @@ #:include "common.fypp" -submodule(stdlib_lapack_base) stdlib_lapack_auxiliary_parameters +submodule(stdlib_lapack_base) stdlib_lapack_auxiliary implicit none @@ -788,5 +788,299 @@ submodule(stdlib_lapack_base) stdlib_lapack_auxiliary_parameters #:endfor + + pure module 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..-- + use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone + ! Scalar Arguments + real(sp), intent(inout) :: a + real(sp), intent(in) :: b, c, d + real(sp), intent(out) :: p, q + ! ===================================================================== + + ! Local Scalars + real(sp) :: r, t + ! Executable Statements + r = d / c + t = one / (c + d * r) + p = stdlib${ii}$_sladiv2(a, b, c, d, r, t) + a = -a + q = stdlib${ii}$_sladiv2(b, a, c, d, r, t) + return + end subroutine stdlib${ii}$_sladiv1 + + pure module 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..-- + use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone + ! Scalar Arguments + real(dp), intent(inout) :: a + real(dp), intent(in) :: b, c, d + real(dp), intent(out) :: p, q + ! ===================================================================== + + ! Local Scalars + real(dp) :: r, t + ! Executable Statements + r = d / c + t = one / (c + d * r) + p = stdlib${ii}$_dladiv2(a, b, c, d, r, t) + a = -a + q = stdlib${ii}$_dladiv2(b, a, c, d, r, t) + return + end subroutine stdlib${ii}$_dladiv1 + +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + pure module 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..-- + use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone + ! Scalar Arguments + real(${rk}$), intent(inout) :: a + real(${rk}$), intent(in) :: b, c, d + real(${rk}$), intent(out) :: p, q + ! ===================================================================== + + ! Local Scalars + real(${rk}$) :: r, t + ! Executable Statements + r = d / c + t = one / (c + d * r) + p = stdlib${ii}$_${ri}$ladiv2(a, b, c, d, r, t) + a = -a + q = stdlib${ii}$_${ri}$ladiv2(b, a, c, d, r, t) + return + end subroutine stdlib${ii}$_${ri}$ladiv1 + +#:endif +#:endfor + + + + pure real(sp) module 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..-- + use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone + ! Scalar Arguments + real(sp), intent(in) :: a, b, c, d, r, t + ! ===================================================================== + + ! Local Scalars + real(sp) :: br + ! Executable Statements + if( r/=zero ) then + br = b * r + if( br/=zero ) then + stdlib${ii}$_sladiv2 = (a + br) * t + else + stdlib${ii}$_sladiv2 = a * t + (b * t) * r + end if + else + stdlib${ii}$_sladiv2 = (a + d * (b / c)) * t + end if + return + end function stdlib${ii}$_sladiv2 + + pure real(dp) module 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..-- + use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone + ! Scalar Arguments + real(dp), intent(in) :: a, b, c, d, r, t + ! ===================================================================== + + ! Local Scalars + real(dp) :: br + ! Executable Statements + if( r/=zero ) then + br = b * r + if( br/=zero ) then + stdlib${ii}$_dladiv2 = (a + br) * t + else + stdlib${ii}$_dladiv2 = a * t + (b * t) * r + end if + else + stdlib${ii}$_dladiv2 = (a + d * (b / c)) * t + end if + return + end function stdlib${ii}$_dladiv2 + +#:for rk,rt,ri in REAL_KINDS_TYPES +#:if not rk in ["sp","dp"] + pure real(${rk}$) module 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..-- + use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone + ! Scalar Arguments + real(${rk}$), intent(in) :: a, b, c, d, r, t + ! ===================================================================== + + ! Local Scalars + real(${rk}$) :: br + ! Executable Statements + if( r/=zero ) then + br = b * r + if( br/=zero ) then + stdlib${ii}$_${ri}$ladiv2 = (a + br) * t + else + stdlib${ii}$_${ri}$ladiv2 = a * t + (b * t) * r + end if + else + stdlib${ii}$_${ri}$ladiv2 = (a + d * (b / c)) * t + end if + return + end function stdlib${ii}$_${ri}$ladiv2 + +#:endif +#:endfor + + + + pure module subroutine stdlib${ii}$_crot( n, cx, incx, cy, incy, c, s ) + !! CROT applies a plane rotation, where the cos (C) is real and the + !! sin (S) is complex, and the vectors CX and CY are complex. + ! -- lapack auxiliary routine -- + ! -- lapack is a software package provided by univ. of tennessee, -- + ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- + use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone + ! Scalar Arguments + integer(${ik}$), intent(in) :: incx, incy, n + real(sp), intent(in) :: c + complex(sp), intent(in) :: s + ! Array Arguments + complex(sp), intent(inout) :: cx(*), cy(*) + ! ===================================================================== + ! Local Scalars + integer(${ik}$) :: i, ix, iy + complex(sp) :: stemp + ! Intrinsic Functions + ! 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_${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 + stemp = c*cx( ix ) + s*cy( iy ) + cy( iy ) = c*cy( iy ) - conjg( s )*cx( ix ) + cx( ix ) = stemp + ix = ix + incx + iy = iy + incy + end do + return + ! code for both increments equal to 1 + 20 continue + do i = 1, n + stemp = c*cx( i ) + s*cy( i ) + cy( i ) = c*cy( i ) - conjg( s )*cx( i ) + cx( i ) = stemp + end do + return + end subroutine stdlib${ii}$_crot + + pure module subroutine stdlib${ii}$_zrot( n, cx, incx, cy, incy, c, s ) + !! ZROT applies a plane rotation, where the cos (C) is real and the + !! sin (S) is complex, and the vectors CX and CY are complex. + ! -- lapack auxiliary routine -- + ! -- lapack is a software package provided by univ. of tennessee, -- + ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- + use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone + ! Scalar Arguments + integer(${ik}$), intent(in) :: incx, incy, n + real(dp), intent(in) :: c + complex(dp), intent(in) :: s + ! Array Arguments + complex(dp), intent(inout) :: cx(*), cy(*) + ! ===================================================================== + ! Local Scalars + integer(${ik}$) :: i, ix, iy + complex(dp) :: stemp + ! Intrinsic Functions + ! 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_${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 + stemp = c*cx( ix ) + s*cy( iy ) + cy( iy ) = c*cy( iy ) - conjg( s )*cx( ix ) + cx( ix ) = stemp + ix = ix + incx + iy = iy + incy + end do + return + ! code for both increments equal to 1 + 20 continue + do i = 1, n + stemp = c*cx( i ) + s*cy( i ) + cy( i ) = c*cy( i ) - conjg( s )*cx( i ) + cx( i ) = stemp + end do + return + end subroutine stdlib${ii}$_zrot + +#:for ck,ct,ci in CMPLX_KINDS_TYPES +#:if not ck in ["sp","dp"] + pure module subroutine stdlib${ii}$_${ci}$rot( n, cx, incx, cy, incy, c, s ) + !! ZROT: applies a plane rotation, where the cos (C) is real and the + !! sin (S) is complex, and the vectors CX and CY are complex. + ! -- lapack auxiliary routine -- + ! -- lapack is a software package provided by univ. of tennessee, -- + ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- + use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone + ! Scalar Arguments + integer(${ik}$), intent(in) :: incx, incy, n + real(${ck}$), intent(in) :: c + complex(${ck}$), intent(in) :: s + ! Array Arguments + complex(${ck}$), intent(inout) :: cx(*), cy(*) + ! ===================================================================== + ! Local Scalars + integer(${ik}$) :: i, ix, iy + complex(${ck}$) :: stemp + ! Intrinsic Functions + ! 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_${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 + stemp = c*cx( ix ) + s*cy( iy ) + cy( iy ) = c*cy( iy ) - conjg( s )*cx( ix ) + cx( ix ) = stemp + ix = ix + incx + iy = iy + incy + end do + return + ! code for both increments equal to 1 + 20 continue + do i = 1, n + stemp = c*cx( i ) + s*cy( i ) + cy( i ) = c*cy( i ) - conjg( s )*cx( i ) + cx( i ) = stemp + end do + return + end subroutine stdlib${ii}$_${ci}$rot + +#:endif +#:endfor + + #:endfor -end submodule stdlib_lapack_auxiliary_parameters +end submodule stdlib_lapack_auxiliary diff --git a/src/lapack/stdlib_lapack_auxiliary_others.fypp b/src/lapack/stdlib_lapack_auxiliary_others.fypp deleted file mode 100644 index 26c3e64ee..000000000 --- a/src/lapack/stdlib_lapack_auxiliary_others.fypp +++ /dev/null @@ -1,303 +0,0 @@ -#:include "common.fypp" -submodule(stdlib_lapack_base) stdlib_lapack_auxiliary_others - implicit none - - - contains -#:for ik,it,ii in LINALG_INT_KINDS_TYPES - - pure module 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..-- - use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone - ! Scalar Arguments - real(sp), intent(inout) :: a - real(sp), intent(in) :: b, c, d - real(sp), intent(out) :: p, q - ! ===================================================================== - - ! Local Scalars - real(sp) :: r, t - ! Executable Statements - r = d / c - t = one / (c + d * r) - p = stdlib${ii}$_sladiv2(a, b, c, d, r, t) - a = -a - q = stdlib${ii}$_sladiv2(b, a, c, d, r, t) - return - end subroutine stdlib${ii}$_sladiv1 - - pure module 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..-- - use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone - ! Scalar Arguments - real(dp), intent(inout) :: a - real(dp), intent(in) :: b, c, d - real(dp), intent(out) :: p, q - ! ===================================================================== - - ! Local Scalars - real(dp) :: r, t - ! Executable Statements - r = d / c - t = one / (c + d * r) - p = stdlib${ii}$_dladiv2(a, b, c, d, r, t) - a = -a - q = stdlib${ii}$_dladiv2(b, a, c, d, r, t) - return - end subroutine stdlib${ii}$_dladiv1 - -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - pure module 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..-- - use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone - ! Scalar Arguments - real(${rk}$), intent(inout) :: a - real(${rk}$), intent(in) :: b, c, d - real(${rk}$), intent(out) :: p, q - ! ===================================================================== - - ! Local Scalars - real(${rk}$) :: r, t - ! Executable Statements - r = d / c - t = one / (c + d * r) - p = stdlib${ii}$_${ri}$ladiv2(a, b, c, d, r, t) - a = -a - q = stdlib${ii}$_${ri}$ladiv2(b, a, c, d, r, t) - return - end subroutine stdlib${ii}$_${ri}$ladiv1 - -#:endif -#:endfor - - - - pure real(sp) module 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..-- - use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone - ! Scalar Arguments - real(sp), intent(in) :: a, b, c, d, r, t - ! ===================================================================== - - ! Local Scalars - real(sp) :: br - ! Executable Statements - if( r/=zero ) then - br = b * r - if( br/=zero ) then - stdlib${ii}$_sladiv2 = (a + br) * t - else - stdlib${ii}$_sladiv2 = a * t + (b * t) * r - end if - else - stdlib${ii}$_sladiv2 = (a + d * (b / c)) * t - end if - return - end function stdlib${ii}$_sladiv2 - - pure real(dp) module 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..-- - use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone - ! Scalar Arguments - real(dp), intent(in) :: a, b, c, d, r, t - ! ===================================================================== - - ! Local Scalars - real(dp) :: br - ! Executable Statements - if( r/=zero ) then - br = b * r - if( br/=zero ) then - stdlib${ii}$_dladiv2 = (a + br) * t - else - stdlib${ii}$_dladiv2 = a * t + (b * t) * r - end if - else - stdlib${ii}$_dladiv2 = (a + d * (b / c)) * t - end if - return - end function stdlib${ii}$_dladiv2 - -#:for rk,rt,ri in REAL_KINDS_TYPES -#:if not rk in ["sp","dp"] - pure real(${rk}$) module 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..-- - use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone - ! Scalar Arguments - real(${rk}$), intent(in) :: a, b, c, d, r, t - ! ===================================================================== - - ! Local Scalars - real(${rk}$) :: br - ! Executable Statements - if( r/=zero ) then - br = b * r - if( br/=zero ) then - stdlib${ii}$_${ri}$ladiv2 = (a + br) * t - else - stdlib${ii}$_${ri}$ladiv2 = a * t + (b * t) * r - end if - else - stdlib${ii}$_${ri}$ladiv2 = (a + d * (b / c)) * t - end if - return - end function stdlib${ii}$_${ri}$ladiv2 - -#:endif -#:endfor - - - - pure module subroutine stdlib${ii}$_crot( n, cx, incx, cy, incy, c, s ) - !! CROT applies a plane rotation, where the cos (C) is real and the - !! sin (S) is complex, and the vectors CX and CY are complex. - ! -- lapack auxiliary routine -- - ! -- lapack is a software package provided by univ. of tennessee, -- - ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- - use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone - ! Scalar Arguments - integer(${ik}$), intent(in) :: incx, incy, n - real(sp), intent(in) :: c - complex(sp), intent(in) :: s - ! Array Arguments - complex(sp), intent(inout) :: cx(*), cy(*) - ! ===================================================================== - ! Local Scalars - integer(${ik}$) :: i, ix, iy - complex(sp) :: stemp - ! Intrinsic Functions - ! 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_${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 - stemp = c*cx( ix ) + s*cy( iy ) - cy( iy ) = c*cy( iy ) - conjg( s )*cx( ix ) - cx( ix ) = stemp - ix = ix + incx - iy = iy + incy - end do - return - ! code for both increments equal to 1 - 20 continue - do i = 1, n - stemp = c*cx( i ) + s*cy( i ) - cy( i ) = c*cy( i ) - conjg( s )*cx( i ) - cx( i ) = stemp - end do - return - end subroutine stdlib${ii}$_crot - - pure module subroutine stdlib${ii}$_zrot( n, cx, incx, cy, incy, c, s ) - !! ZROT applies a plane rotation, where the cos (C) is real and the - !! sin (S) is complex, and the vectors CX and CY are complex. - ! -- lapack auxiliary routine -- - ! -- lapack is a software package provided by univ. of tennessee, -- - ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- - use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone - ! Scalar Arguments - integer(${ik}$), intent(in) :: incx, incy, n - real(dp), intent(in) :: c - complex(dp), intent(in) :: s - ! Array Arguments - complex(dp), intent(inout) :: cx(*), cy(*) - ! ===================================================================== - ! Local Scalars - integer(${ik}$) :: i, ix, iy - complex(dp) :: stemp - ! Intrinsic Functions - ! 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_${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 - stemp = c*cx( ix ) + s*cy( iy ) - cy( iy ) = c*cy( iy ) - conjg( s )*cx( ix ) - cx( ix ) = stemp - ix = ix + incx - iy = iy + incy - end do - return - ! code for both increments equal to 1 - 20 continue - do i = 1, n - stemp = c*cx( i ) + s*cy( i ) - cy( i ) = c*cy( i ) - conjg( s )*cx( i ) - cx( i ) = stemp - end do - return - end subroutine stdlib${ii}$_zrot - -#:for ck,ct,ci in CMPLX_KINDS_TYPES -#:if not ck in ["sp","dp"] - pure module subroutine stdlib${ii}$_${ci}$rot( n, cx, incx, cy, incy, c, s ) - !! ZROT: applies a plane rotation, where the cos (C) is real and the - !! sin (S) is complex, and the vectors CX and CY are complex. - ! -- lapack auxiliary routine -- - ! -- lapack is a software package provided by univ. of tennessee, -- - ! -- univ. of california berkeley, univ. of colorado denver and nag ltd..-- - use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone - ! Scalar Arguments - integer(${ik}$), intent(in) :: incx, incy, n - real(${ck}$), intent(in) :: c - complex(${ck}$), intent(in) :: s - ! Array Arguments - complex(${ck}$), intent(inout) :: cx(*), cy(*) - ! ===================================================================== - ! Local Scalars - integer(${ik}$) :: i, ix, iy - complex(${ck}$) :: stemp - ! Intrinsic Functions - ! 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_${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 - stemp = c*cx( ix ) + s*cy( iy ) - cy( iy ) = c*cy( iy ) - conjg( s )*cx( ix ) - cx( ix ) = stemp - ix = ix + incx - iy = iy + incy - end do - return - ! code for both increments equal to 1 - 20 continue - do i = 1, n - stemp = c*cx( i ) + s*cy( i ) - cy( i ) = c*cy( i ) - conjg( s )*cx( i ) - cx( i ) = stemp - end do - return - end subroutine stdlib${ii}$_${ci}$rot - -#:endif -#:endfor - - -#:endfor -end submodule stdlib_lapack_auxiliary_others