|
1 | 1 | #:include "common.fypp"
|
2 |
| -submodule(stdlib_lapack_base) stdlib_lapack_auxiliary_parameters |
| 2 | +submodule(stdlib_lapack_base) stdlib_lapack_auxiliary |
3 | 3 | implicit none
|
4 | 4 |
|
5 | 5 |
|
@@ -788,5 +788,299 @@ submodule(stdlib_lapack_base) stdlib_lapack_auxiliary_parameters
|
788 | 788 | #:endfor
|
789 | 789 |
|
790 | 790 |
|
| 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 | + |
791 | 1085 | #:endfor
|
792 |
| -end submodule stdlib_lapack_auxiliary_parameters |
| 1086 | +end submodule stdlib_lapack_auxiliary |
0 commit comments