Skip to content

Commit aae57c3

Browse files
jalveszjalvesz
committed
merge lapack auxiliaries
1 parent ddbd574 commit aae57c3

File tree

4 files changed

+300
-312
lines changed

4 files changed

+300
-312
lines changed

‎legacy/refactor_blaslapack_subm.py

Lines changed: 3 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -27,11 +27,9 @@
2727

2828
# Define the LAPACK routine groups
2929
lapack_groups = {
30-
"auxiliary_parameters": [
30+
"auxiliary": [
3131
"lamch", "lamc3", "labad", "csum1", "zsum1",
32-
"laqsb"
33-
],
34-
"auxiliary_others": [
32+
"laqsb",
3533
"ladiv1","ladiv2", "rot"
3634
],
3735

@@ -252,7 +250,7 @@
252250
lapack_subgroups = {
253251
"base" : {
254252
"dependencies" : [],
255-
"members" : ["auxiliary_parameters","auxiliary_others","blas_like_base",
253+
"members" : ["auxiliary","blas_like_base",
256254
"blas_like_scalar","blas_like_l1","blas_like_l2","blas_like_l3","blas_like_mnorm",
257255
"givens_jacobi_rot","householder_reflectors"],
258256
},

‎src/CMakeLists.txt

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -105,8 +105,7 @@ set(cppFiles
105105
lapack/stdlib_lapack_eig_svd_lsq.fypp
106106

107107
lapack/stdlib_linalg_lapack_aux.fypp
108-
lapack/stdlib_lapack_auxiliary_others.fypp
109-
lapack/stdlib_lapack_auxiliary_parameters.fypp
108+
lapack/stdlib_lapack_auxiliary.fypp
110109
lapack/stdlib_lapack_blas_like_base.fypp
111110
lapack/stdlib_lapack_blas_like_l1.fypp
112111
lapack/stdlib_lapack_blas_like_l2.fypp

‎src/lapack/stdlib_lapack_auxiliary_parameters.fypp renamed to ‎src/lapack/stdlib_lapack_auxiliary.fypp

Lines changed: 296 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
#:include "common.fypp"
2-
submodule(stdlib_lapack_base) stdlib_lapack_auxiliary_parameters
2+
submodule(stdlib_lapack_base) stdlib_lapack_auxiliary
33
implicit none
44

55

@@ -788,5 +788,299 @@ submodule(stdlib_lapack_base) stdlib_lapack_auxiliary_parameters
788788
#:endfor
789789

790790

791+
792+
pure module subroutine stdlib${ii}$_sladiv1( a, b, c, d, p, q )
793+
! -- lapack auxiliary routine --
794+
! -- lapack is a software package provided by univ. of tennessee, --
795+
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
796+
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
797+
! Scalar Arguments
798+
real(sp), intent(inout) :: a
799+
real(sp), intent(in) :: b, c, d
800+
real(sp), intent(out) :: p, q
801+
! =====================================================================
802+
803+
! Local Scalars
804+
real(sp) :: r, t
805+
! Executable Statements
806+
r = d / c
807+
t = one / (c + d * r)
808+
p = stdlib${ii}$_sladiv2(a, b, c, d, r, t)
809+
a = -a
810+
q = stdlib${ii}$_sladiv2(b, a, c, d, r, t)
811+
return
812+
end subroutine stdlib${ii}$_sladiv1
813+
814+
pure module subroutine stdlib${ii}$_dladiv1( a, b, c, d, p, q )
815+
! -- lapack auxiliary routine --
816+
! -- lapack is a software package provided by univ. of tennessee, --
817+
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
818+
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
819+
! Scalar Arguments
820+
real(dp), intent(inout) :: a
821+
real(dp), intent(in) :: b, c, d
822+
real(dp), intent(out) :: p, q
823+
! =====================================================================
824+
825+
! Local Scalars
826+
real(dp) :: r, t
827+
! Executable Statements
828+
r = d / c
829+
t = one / (c + d * r)
830+
p = stdlib${ii}$_dladiv2(a, b, c, d, r, t)
831+
a = -a
832+
q = stdlib${ii}$_dladiv2(b, a, c, d, r, t)
833+
return
834+
end subroutine stdlib${ii}$_dladiv1
835+
836+
#:for rk,rt,ri in REAL_KINDS_TYPES
837+
#:if not rk in ["sp","dp"]
838+
pure module subroutine stdlib${ii}$_${ri}$ladiv1( a, b, c, d, p, q )
839+
! -- lapack auxiliary routine --
840+
! -- lapack is a software package provided by univ. of tennessee, --
841+
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
842+
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
843+
! Scalar Arguments
844+
real(${rk}$), intent(inout) :: a
845+
real(${rk}$), intent(in) :: b, c, d
846+
real(${rk}$), intent(out) :: p, q
847+
! =====================================================================
848+
849+
! Local Scalars
850+
real(${rk}$) :: r, t
851+
! Executable Statements
852+
r = d / c
853+
t = one / (c + d * r)
854+
p = stdlib${ii}$_${ri}$ladiv2(a, b, c, d, r, t)
855+
a = -a
856+
q = stdlib${ii}$_${ri}$ladiv2(b, a, c, d, r, t)
857+
return
858+
end subroutine stdlib${ii}$_${ri}$ladiv1
859+
860+
#:endif
861+
#:endfor
862+
863+
864+
865+
pure real(sp) module function stdlib${ii}$_sladiv2( a, b, c, d, r, t )
866+
! -- lapack auxiliary routine --
867+
! -- lapack is a software package provided by univ. of tennessee, --
868+
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
869+
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
870+
! Scalar Arguments
871+
real(sp), intent(in) :: a, b, c, d, r, t
872+
! =====================================================================
873+
874+
! Local Scalars
875+
real(sp) :: br
876+
! Executable Statements
877+
if( r/=zero ) then
878+
br = b * r
879+
if( br/=zero ) then
880+
stdlib${ii}$_sladiv2 = (a + br) * t
881+
else
882+
stdlib${ii}$_sladiv2 = a * t + (b * t) * r
883+
end if
884+
else
885+
stdlib${ii}$_sladiv2 = (a + d * (b / c)) * t
886+
end if
887+
return
888+
end function stdlib${ii}$_sladiv2
889+
890+
pure real(dp) module function stdlib${ii}$_dladiv2( a, b, c, d, r, t )
891+
! -- lapack auxiliary routine --
892+
! -- lapack is a software package provided by univ. of tennessee, --
893+
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
894+
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
895+
! Scalar Arguments
896+
real(dp), intent(in) :: a, b, c, d, r, t
897+
! =====================================================================
898+
899+
! Local Scalars
900+
real(dp) :: br
901+
! Executable Statements
902+
if( r/=zero ) then
903+
br = b * r
904+
if( br/=zero ) then
905+
stdlib${ii}$_dladiv2 = (a + br) * t
906+
else
907+
stdlib${ii}$_dladiv2 = a * t + (b * t) * r
908+
end if
909+
else
910+
stdlib${ii}$_dladiv2 = (a + d * (b / c)) * t
911+
end if
912+
return
913+
end function stdlib${ii}$_dladiv2
914+
915+
#:for rk,rt,ri in REAL_KINDS_TYPES
916+
#:if not rk in ["sp","dp"]
917+
pure real(${rk}$) module function stdlib${ii}$_${ri}$ladiv2( a, b, c, d, r, t )
918+
! -- lapack auxiliary routine --
919+
! -- lapack is a software package provided by univ. of tennessee, --
920+
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
921+
use stdlib_blas_constants_${rk}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
922+
! Scalar Arguments
923+
real(${rk}$), intent(in) :: a, b, c, d, r, t
924+
! =====================================================================
925+
926+
! Local Scalars
927+
real(${rk}$) :: br
928+
! Executable Statements
929+
if( r/=zero ) then
930+
br = b * r
931+
if( br/=zero ) then
932+
stdlib${ii}$_${ri}$ladiv2 = (a + br) * t
933+
else
934+
stdlib${ii}$_${ri}$ladiv2 = a * t + (b * t) * r
935+
end if
936+
else
937+
stdlib${ii}$_${ri}$ladiv2 = (a + d * (b / c)) * t
938+
end if
939+
return
940+
end function stdlib${ii}$_${ri}$ladiv2
941+
942+
#:endif
943+
#:endfor
944+
945+
946+
947+
pure module subroutine stdlib${ii}$_crot( n, cx, incx, cy, incy, c, s )
948+
!! CROT applies a plane rotation, where the cos (C) is real and the
949+
!! sin (S) is complex, and the vectors CX and CY are complex.
950+
! -- lapack auxiliary routine --
951+
! -- lapack is a software package provided by univ. of tennessee, --
952+
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
953+
use stdlib_blas_constants_sp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
954+
! Scalar Arguments
955+
integer(${ik}$), intent(in) :: incx, incy, n
956+
real(sp), intent(in) :: c
957+
complex(sp), intent(in) :: s
958+
! Array Arguments
959+
complex(sp), intent(inout) :: cx(*), cy(*)
960+
! =====================================================================
961+
! Local Scalars
962+
integer(${ik}$) :: i, ix, iy
963+
complex(sp) :: stemp
964+
! Intrinsic Functions
965+
! Executable Statements
966+
if( n<=0 )return
967+
if( incx==1 .and. incy==1 )go to 20
968+
! code for unequal increments or equal increments not equal to 1
969+
ix = 1_${ik}$
970+
iy = 1_${ik}$
971+
if( incx<0_${ik}$ )ix = ( -n+1 )*incx + 1_${ik}$
972+
if( incy<0_${ik}$ )iy = ( -n+1 )*incy + 1_${ik}$
973+
do i = 1, n
974+
stemp = c*cx( ix ) + s*cy( iy )
975+
cy( iy ) = c*cy( iy ) - conjg( s )*cx( ix )
976+
cx( ix ) = stemp
977+
ix = ix + incx
978+
iy = iy + incy
979+
end do
980+
return
981+
! code for both increments equal to 1
982+
20 continue
983+
do i = 1, n
984+
stemp = c*cx( i ) + s*cy( i )
985+
cy( i ) = c*cy( i ) - conjg( s )*cx( i )
986+
cx( i ) = stemp
987+
end do
988+
return
989+
end subroutine stdlib${ii}$_crot
990+
991+
pure module subroutine stdlib${ii}$_zrot( n, cx, incx, cy, incy, c, s )
992+
!! ZROT applies a plane rotation, where the cos (C) is real and the
993+
!! sin (S) is complex, and the vectors CX and CY are complex.
994+
! -- lapack auxiliary routine --
995+
! -- lapack is a software package provided by univ. of tennessee, --
996+
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
997+
use stdlib_blas_constants_dp, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
998+
! Scalar Arguments
999+
integer(${ik}$), intent(in) :: incx, incy, n
1000+
real(dp), intent(in) :: c
1001+
complex(dp), intent(in) :: s
1002+
! Array Arguments
1003+
complex(dp), intent(inout) :: cx(*), cy(*)
1004+
! =====================================================================
1005+
! Local Scalars
1006+
integer(${ik}$) :: i, ix, iy
1007+
complex(dp) :: stemp
1008+
! Intrinsic Functions
1009+
! Executable Statements
1010+
if( n<=0 )return
1011+
if( incx==1 .and. incy==1 )go to 20
1012+
! code for unequal increments or equal increments not equal to 1
1013+
ix = 1_${ik}$
1014+
iy = 1_${ik}$
1015+
if( incx<0_${ik}$ )ix = ( -n+1 )*incx + 1_${ik}$
1016+
if( incy<0_${ik}$ )iy = ( -n+1 )*incy + 1_${ik}$
1017+
do i = 1, n
1018+
stemp = c*cx( ix ) + s*cy( iy )
1019+
cy( iy ) = c*cy( iy ) - conjg( s )*cx( ix )
1020+
cx( ix ) = stemp
1021+
ix = ix + incx
1022+
iy = iy + incy
1023+
end do
1024+
return
1025+
! code for both increments equal to 1
1026+
20 continue
1027+
do i = 1, n
1028+
stemp = c*cx( i ) + s*cy( i )
1029+
cy( i ) = c*cy( i ) - conjg( s )*cx( i )
1030+
cx( i ) = stemp
1031+
end do
1032+
return
1033+
end subroutine stdlib${ii}$_zrot
1034+
1035+
#:for ck,ct,ci in CMPLX_KINDS_TYPES
1036+
#:if not ck in ["sp","dp"]
1037+
pure module subroutine stdlib${ii}$_${ci}$rot( n, cx, incx, cy, incy, c, s )
1038+
!! ZROT: applies a plane rotation, where the cos (C) is real and the
1039+
!! sin (S) is complex, and the vectors CX and CY are complex.
1040+
! -- lapack auxiliary routine --
1041+
! -- lapack is a software package provided by univ. of tennessee, --
1042+
! -- univ. of california berkeley, univ. of colorado denver and nag ltd..--
1043+
use stdlib_blas_constants_${ck}$, only: negone, zero, half, one, two, three, four, eight, ten, czero, chalf, cone, cnegone
1044+
! Scalar Arguments
1045+
integer(${ik}$), intent(in) :: incx, incy, n
1046+
real(${ck}$), intent(in) :: c
1047+
complex(${ck}$), intent(in) :: s
1048+
! Array Arguments
1049+
complex(${ck}$), intent(inout) :: cx(*), cy(*)
1050+
! =====================================================================
1051+
! Local Scalars
1052+
integer(${ik}$) :: i, ix, iy
1053+
complex(${ck}$) :: stemp
1054+
! Intrinsic Functions
1055+
! Executable Statements
1056+
if( n<=0 )return
1057+
if( incx==1 .and. incy==1 )go to 20
1058+
! code for unequal increments or equal increments not equal to 1
1059+
ix = 1_${ik}$
1060+
iy = 1_${ik}$
1061+
if( incx<0_${ik}$ )ix = ( -n+1 )*incx + 1_${ik}$
1062+
if( incy<0_${ik}$ )iy = ( -n+1 )*incy + 1_${ik}$
1063+
do i = 1, n
1064+
stemp = c*cx( ix ) + s*cy( iy )
1065+
cy( iy ) = c*cy( iy ) - conjg( s )*cx( ix )
1066+
cx( ix ) = stemp
1067+
ix = ix + incx
1068+
iy = iy + incy
1069+
end do
1070+
return
1071+
! code for both increments equal to 1
1072+
20 continue
1073+
do i = 1, n
1074+
stemp = c*cx( i ) + s*cy( i )
1075+
cy( i ) = c*cy( i ) - conjg( s )*cx( i )
1076+
cx( i ) = stemp
1077+
end do
1078+
return
1079+
end subroutine stdlib${ii}$_${ci}$rot
1080+
1081+
#:endif
1082+
#:endfor
1083+
1084+
7911085
#:endfor
792-
end submodule stdlib_lapack_auxiliary_parameters
1086+
end submodule stdlib_lapack_auxiliary

0 commit comments

Comments
 (0)