merge lapack auxiliaries

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"],
     },

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

src/lapack/stdlib_lapack_auxiliary_parameters.fypp → 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