diff --git a/cmake/lapack.cmake b/cmake/lapack.cmake index d08ba22371..81f0bcd386 100644 --- a/cmake/lapack.cmake +++ b/cmake/lapack.cmake @@ -136,7 +136,8 @@ set(SLASRC slaorhr_col_getrfnp2.f sorgtsqr.f sorgtsqr_row.f sorhr_col.f slatrs3.f strsyl3.f sgelst.f sgedmd.f90 sgedmdq.f90 sgecxx.f sbdsvdmr3.f sbdsvdmr3_work.f sgesvdmr3.f sbdtgk.f slar1v_tgk.f - slarrf_tgk.f slarrb_tgk.f slarrv_tgk.f) + slarrf_tgk.f slarrb_tgk.f slarrv_tgk.f slaed0_br.f slaed0_merge_pair.f + slaed4_br.f slaed7_br.f slaed8_br.f slaed9_br.f sstebr.f ssteqr_boundary_br.f) set(SXLASRC sgesvxx.f sgerfsx.f sla_gerfsx_extended.f sla_geamv.f sla_gercond.f sla_gerpvgrw.f ssysvxx.f ssyrfsx.f @@ -332,7 +333,8 @@ set(DLASRC dlaorhr_col_getrfnp2.f dorgtsqr.f dorgtsqr_row.f dorhr_col.f dlatrs3.f dtrsyl3.f dgelst.f dgedmd.f90 dgedmdq.f90 dgecxx.f dbdsvdmr3.f dbdsvdmr3_work.f dgesvdmr3.f dbdtgk.f dlar1v_tgk.f - dlarrf_tgk.f dlarrb_tgk.f dlarrv_tgk.f) + dlarrf_tgk.f dlarrb_tgk.f dlarrv_tgk.f dlaed0_br.f dlaed0_merge_pair.f + dlaed4_br.f dlaed7_br.f dlaed8_br.f dlaed9_br.f dstebr.f dsteqr_boundary_br.f) set(DXLASRC dgesvxx.f dgerfsx.f dla_gerfsx_extended.f dla_geamv.f dla_gercond.f dla_gerpvgrw.f dsysvxx.f dsyrfsx.f @@ -647,7 +649,8 @@ set(SLASRC slaorhr_col_getrfnp2.c sorgtsqr.c sorgtsqr_row.c sorhr_col.c slatrs3.c strsyl3.c sgelst.c sgedmd.c sgedmdq.c sgecxx.c sbdsvdmr3.c sbdsvdmr3_work.c sgesvdmr3.c sbdtgk.c slar1v_tgk.c - slarrf_tgk.c slarrb_tgk.c slarrv_tgk.c) + slarrf_tgk.c slarrb_tgk.c slarrv_tgk.c slaed0_br.c slaed0_merge_pair.c + slaed4_br.c slaed7_br.c slaed8_br.c slaed9_br.c sstebr.c ssteqr_boundary_br.c) set(SXLASRC sgesvxx.c sgerfsx.c sla_gerfsx_extended.c sla_geamv.c sla_gercond.c sla_gerpvgrw.c ssysvxx.c ssyrfsx.c @@ -840,7 +843,8 @@ set(DLASRC dlaorhr_col_getrfnp2.c dorgtsqr.c dorgtsqr_row.c dorhr_col.c dlatrs3.c dtrsyl3.c dgelst.c dgedmd.c dgedmdq.c dgecxx.c dbdsvdmr3.c dbdsvdmr3_work.c dgesvdmr3.c dbdtgk.c dlar1v_tgk.c - dlarrf_tgk.c dlarrb_tgk.c dlarrv_tgk.c) + dlarrf_tgk.c dlarrb_tgk.c dlarrv_tgk.c dlaed0_br.c dlaed0_merge_pair.c + dlaed4_br.c dlaed7_br.c dlaed8_br.c dlaed9_br.c dstebr.c dsteqr_boundary_br.c) set(DXLASRC dgesvxx.c dgerfsx.c dla_gerfsx_extended.c dla_geamv.c dla_gercond.c dla_gerpvgrw.c dsysvxx.c dsyrfsx.c diff --git a/cmake/lapacke.cmake b/cmake/lapacke.cmake index e28afa86ff..41580dbfec 100644 --- a/cmake/lapacke.cmake +++ b/cmake/lapacke.cmake @@ -1036,6 +1036,8 @@ set(DSRC lapacke_dsptri_work.c lapacke_dsptrs.c lapacke_dsptrs_work.c + lapacke_dstebr.c + lapacke_dstebr_work.c lapacke_dstebz.c lapacke_dstebz_work.c lapacke_dstedc.c @@ -1619,6 +1621,8 @@ set(SSRC lapacke_ssptri_work.c lapacke_ssptrs.c lapacke_ssptrs_work.c + lapacke_sstebr.c + lapacke_sstebr_work.c lapacke_sstebz.c lapacke_sstebz_work.c lapacke_sstedc.c diff --git a/exports/gensymbol b/exports/gensymbol index d0ef2b25d4..0d4d3fdcdd 100755 --- a/exports/gensymbol +++ b/exports/gensymbol @@ -949,6 +949,14 @@ lapackobjs2d="$lapackobjs2d dlarrb_tgk dlarrf_tgk dlarrv_tgk + dlaed0_br + dlaed0_merge_pair + dlaed4_br + dlaed7_br + dlaed8_br + dlaed9_br + dstebr + dsteqr_boundary_br " # dlaqz0 # dlaqz1 @@ -973,6 +981,14 @@ lapackobjs2s="$lapackobjs2s slarrb_tgk slarrf_tgk slarrv_tgk + dlaed0_br + dlaed0_merge_pair + dlaed4_br + dlaed7_br + dlaed8_br + dlaed9_br + dstebr + dsteqr_boundary_br " lapackobjs2z="$lapackobjs2z @@ -2401,6 +2417,8 @@ lapackeobjsd=" LAPACKE_dbdsvdmr3_work LAPACKE_dgesvdmr3 LAPACKE_dgesvdmr3_work + LAPACKE_dstebr + LAPACKE_dstebr_work " lapackeobjss=" @@ -3024,6 +3042,8 @@ lapackeobjss=" LAPACKE_sbdsvdmr3_work LAPACKE_sgesvdmr3 LAPACKE_sgesvdmr3_work + LAPACKE_sstebr + LAPACKE_sstebr_work " lapackeobjsz=" diff --git a/exports/gensymbol.pl b/exports/gensymbol.pl index 573ffb6984..2ff4aa247f 100644 --- a/exports/gensymbol.pl +++ b/exports/gensymbol.pl @@ -922,7 +922,15 @@ dlar1v_tgk, dlarrb_tgk, dlarrf_tgk, - dlarrv_tgk + dlarrv_tgk, + dlaed0_br, + dlaed0_merge_pair, + dlaed4_br, + dlaed7_br, + dlaed8_br, + dlaed9_br, + dstebr, + dsteqr_boundary_br ); @lapackobjs2s = (@lapackobjs2s, @@ -941,7 +949,15 @@ slar1v_tgk, slarrb_tgk, slarrf_tgk, - slarrv_tgk + slarrv_tgk, + slaed0_br, + slaed0_merge_pair, + slaed4_br, + slaed7_br, + slaed8_br, + slaed9_br, + sstebr, + ssteqr_boundary_br ); @lapackobjs2z = (@lapackobjs2z, @@ -2364,7 +2380,9 @@ LAPACKE_dbdsvdmr3, LAPACKE_dbdsvdmr3_work, LAPACKE_dgesvdmr3, - LAPACKE_dgesvdmr3_work + LAPACKE_dgesvdmr3_work, + LAPACKE_dstebr, + LAPACKE_dstebr_work ); @lapackeobjss = ( LAPACKE_sgb_nancheck, @@ -2986,7 +3004,9 @@ LAPACKE_sbdsvdmr3, LAPACKE_sbdsvdmr3_work, LAPACKE_sgesvdmr3, - LAPACKE_sgesvdmr3_work + LAPACKE_sgesvdmr3_work, + LAPACKE_sstebr, + LAPACKE_sstebr_work ); @lapackeobjsz = ( LAPACKE_zgb_nancheck, diff --git a/lapack-netlib/LAPACKE/include/lapack.h b/lapack-netlib/LAPACKE/include/lapack.h index 1d6997c801..3ec3406ff0 100644 --- a/lapack-netlib/LAPACKE/include/lapack.h +++ b/lapack-netlib/LAPACKE/include/lapack.h @@ -16650,6 +16650,24 @@ void LAPACK_sstebz_base( #define LAPACK_sstebz(...) LAPACK_sstebz_base(__VA_ARGS__) #endif +#define LAPACK_dstebr LAPACK_GLOBAL(dstebr,DSTEBR) +void LAPACK_dstebr( + lapack_int const* n, + double* D, + double* E, + double* work, lapack_int const* lwork, + lapack_int* iwork, lapack_int const* liwork, + lapack_int* info ); + +#define LAPACK_sstebr LAPACK_GLOBAL(sstebr,SSTEBR) +void LAPACK_sstebr( + lapack_int const* n, + float* D, + float* E, + float* work, lapack_int const* lwork, + lapack_int* iwork, lapack_int const* liwork, + lapack_int* info ); + #define LAPACK_cstedc_base LAPACK_GLOBAL(cstedc,CSTEDC) void LAPACK_cstedc_base( char const* compz, diff --git a/lapack-netlib/LAPACKE/include/lapacke.h b/lapack-netlib/LAPACKE/include/lapacke.h index 87db281f12..83e8e2b637 100644 --- a/lapack-netlib/LAPACKE/include/lapacke.h +++ b/lapack-netlib/LAPACKE/include/lapacke.h @@ -3653,6 +3653,9 @@ lapack_int LAPACKE_dstebz( char range, char order, lapack_int n, double vl, lapack_int* m, lapack_int* nsplit, double* w, lapack_int* iblock, lapack_int* isplit ); +lapack_int LAPACKE_sstebr( lapack_int n, float* d, float* e ); +lapack_int LAPACKE_dstebr( lapack_int n, double* d, double* e ); + lapack_int LAPACKE_sstedc( int matrix_layout, char compz, lapack_int n, float* d, float* e, float* z, lapack_int ldz ); lapack_int LAPACKE_dstedc( int matrix_layout, char compz, lapack_int n, @@ -9367,6 +9370,13 @@ lapack_int LAPACKE_dstebz_work( char range, char order, lapack_int n, double vl, lapack_int* iblock, lapack_int* isplit, double* work, lapack_int* iwork ); +lapack_int LAPACKE_sstebr_work( lapack_int n, float* d, float* e, float* work, + lapack_int lwork, lapack_int* iwork, + lapack_int liwork ); +lapack_int LAPACKE_dstebr_work( lapack_int n, double* d, double* e, + double* work, lapack_int lwork, + lapack_int* iwork, lapack_int liwork ); + lapack_int LAPACKE_sstedc_work( int matrix_layout, char compz, lapack_int n, float* d, float* e, float* z, lapack_int ldz, float* work, lapack_int lwork, diff --git a/lapack-netlib/LAPACKE/src/Makefile b/lapack-netlib/LAPACKE/src/Makefile index 6eb729ca41..06e8d71485 100644 --- a/lapack-netlib/LAPACKE/src/Makefile +++ b/lapack-netlib/LAPACKE/src/Makefile @@ -1083,6 +1083,8 @@ lapacke_dsptri.o \ lapacke_dsptri_work.o \ lapacke_dsptrs.o \ lapacke_dsptrs_work.o \ +lapacke_dstebr.o \ +lapacke_dstebr_work.o \ lapacke_dstebz.o \ lapacke_dstebz_work.o \ lapacke_dstedc.o \ @@ -1667,6 +1669,8 @@ lapacke_ssptri.o \ lapacke_ssptri_work.o \ lapacke_ssptrs.o \ lapacke_ssptrs_work.o \ +lapacke_sstebr.o \ +lapacke_sstebr_work.o \ lapacke_sstebz.o \ lapacke_sstebz_work.o \ lapacke_sstedc.o \ diff --git a/lapack-netlib/LAPACKE/src/lapacke_dstebr.c b/lapack-netlib/LAPACKE/src/lapacke_dstebr.c new file mode 100644 index 0000000000..8ab53da12d --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dstebr.c @@ -0,0 +1,87 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + Copyright (c) 2026, Ruiyi Zhan and Shaoshuai Zhang. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function dstebr +* Author: Ruiyi Zhan and Shaoshuai Zhang +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dstebr)( lapack_int n, double* d, double* e ) +{ + lapack_int info = 0; + lapack_int liwork = -1; + lapack_int lwork = -1; + lapack_int* iwork = NULL; + double* work = NULL; + lapack_int iwork_query; + double work_query; +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_d_nancheck)( n, d, 1 ) ) { + return -2; + } + if( API_SUFFIX(LAPACKE_d_nancheck)( n-1, e, 1 ) ) { + return -3; + } + } +#endif + /* Query optimal working array(s) size */ + info = API_SUFFIX(LAPACKE_dstebr_work)( n, d, e, &work_query, lwork, + &iwork_query, liwork ); + if( info != 0 ) { + goto exit_level_0; + } + liwork = iwork_query; + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * liwork ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + work = (double*)LAPACKE_malloc( sizeof(double) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + /* Call middle-level interface */ + info = API_SUFFIX(LAPACKE_dstebr_work)( n, d, e, work, lwork, iwork, + liwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_dstebr", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_dstebr_work.c b/lapack-netlib/LAPACKE/src/lapacke_dstebr_work.c new file mode 100644 index 0000000000..f4dcacde97 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_dstebr_work.c @@ -0,0 +1,44 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + Copyright (c) 2026, Ruiyi Zhan and Shaoshuai Zhang. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function dstebr +* Author: Ruiyi Zhan and Shaoshuai Zhang +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_dstebr_work)( lapack_int n, double* d, double* e, + double* work, lapack_int lwork, + lapack_int* iwork, lapack_int liwork ) +{ + lapack_int info = 0; + /* Call LAPACK function and adjust info */ + LAPACK_dstebr( &n, d, e, work, &lwork, iwork, &liwork, &info ); + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_sstebr.c b/lapack-netlib/LAPACKE/src/lapacke_sstebr.c new file mode 100644 index 0000000000..53add89410 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_sstebr.c @@ -0,0 +1,87 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + Copyright (c) 2026, Ruiyi Zhan and Shaoshuai Zhang. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native high-level C interface to LAPACK function sstebr +* Author: Ruiyi Zhan and Shaoshuai Zhang +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_sstebr)( lapack_int n, float* d, float* e ) +{ + lapack_int info = 0; + lapack_int liwork = -1; + lapack_int lwork = -1; + lapack_int* iwork = NULL; + float* work = NULL; + lapack_int iwork_query; + float work_query; +#ifndef LAPACK_DISABLE_NAN_CHECK + if( LAPACKE_get_nancheck() ) { + /* Optionally check input matrices for NaNs */ + if( API_SUFFIX(LAPACKE_s_nancheck)( n, d, 1 ) ) { + return -2; + } + if( API_SUFFIX(LAPACKE_s_nancheck)( n-1, e, 1 ) ) { + return -3; + } + } +#endif + /* Query optimal working array(s) size */ + info = API_SUFFIX(LAPACKE_sstebr_work)( n, d, e, &work_query, lwork, + &iwork_query, liwork ); + if( info != 0 ) { + goto exit_level_0; + } + liwork = iwork_query; + lwork = (lapack_int)work_query; + /* Allocate memory for work arrays */ + iwork = (lapack_int*)LAPACKE_malloc( sizeof(lapack_int) * liwork ); + if( iwork == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_0; + } + work = (float*)LAPACKE_malloc( sizeof(float) * lwork ); + if( work == NULL ) { + info = LAPACK_WORK_MEMORY_ERROR; + goto exit_level_1; + } + /* Call middle-level interface */ + info = API_SUFFIX(LAPACKE_sstebr_work)( n, d, e, work, lwork, iwork, + liwork ); + /* Release memory and exit */ + LAPACKE_free( work ); +exit_level_1: + LAPACKE_free( iwork ); +exit_level_0: + if( info == LAPACK_WORK_MEMORY_ERROR ) { + API_SUFFIX(LAPACKE_xerbla)( "LAPACKE_sstebr", info ); + } + return info; +} diff --git a/lapack-netlib/LAPACKE/src/lapacke_sstebr_work.c b/lapack-netlib/LAPACKE/src/lapacke_sstebr_work.c new file mode 100644 index 0000000000..c35d076894 --- /dev/null +++ b/lapack-netlib/LAPACKE/src/lapacke_sstebr_work.c @@ -0,0 +1,44 @@ +/***************************************************************************** + Copyright (c) 2014, Intel Corp. + Copyright (c) 2026, Ruiyi Zhan and Shaoshuai Zhang. + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of Intel Corporation nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF + THE POSSIBILITY OF SUCH DAMAGE. +***************************************************************************** +* Contents: Native middle-level C interface to LAPACK function sstebr +* Author: Ruiyi Zhan and Shaoshuai Zhang +*****************************************************************************/ + +#include "lapacke_utils.h" + +lapack_int API_SUFFIX(LAPACKE_sstebr_work)( lapack_int n, float* d, float* e, + float* work, lapack_int lwork, + lapack_int* iwork, lapack_int liwork ) +{ + lapack_int info = 0; + /* Call LAPACK function and adjust info */ + LAPACK_sstebr( &n, d, e, work, &lwork, iwork, &liwork, &info ); + return info; +} diff --git a/lapack-netlib/SRC/Makefile b/lapack-netlib/SRC/Makefile index 511113028b..8de62c11bc 100644 --- a/lapack-netlib/SRC/Makefile +++ b/lapack-netlib/SRC/Makefile @@ -235,7 +235,8 @@ SLASRC_O = \ ssbev_2stage.o ssbevx_2stage.o ssbevd_2stage.o ssygv_2stage.o \ sgesvdq.o slatrs3.o strsyl3.o sgelst.o sgedmd.o sgedmdq.o sgecxx.o \ sbdsvdmr3.o sbdsvdmr3_work.o sbdtgk.o sgesvdmr3.o slar1v_tgk.o \ - slarrb_tgk.o slarrf_tgk.o slarrv_tgk.o + slarrb_tgk.o slarrf_tgk.o slarrv_tgk.o slaed0_br.o slaed0_merge_pair.o \ + slaed4_br.o slaed7_br.o slaed8_br.o slaed9_br.o sstebr.o ssteqr_boundary_br.o endif ifneq "$(or $(BUILD_SINGLE),$(BUILD_DOUBLE))" "" @@ -448,7 +449,8 @@ DLASRC_O = \ dsbev_2stage.o dsbevx_2stage.o dsbevd_2stage.o dsygv_2stage.o \ dgesvdq.o dlatrs3.o dtrsyl3.o dgelst.o dgedmd.o dgedmdq.o dgecxx.o \ dbdsvdmr3.o dbdsvdmr3_work.o dbdtgk.o dgesvdmr3.o dlar1v_tgk.o \ - dlarrb_tgk.o dlarrf_tgk.o dlarrv_tgk.o + dlarrb_tgk.o dlarrf_tgk.o dlarrv_tgk.o dlaed0_br.o dlaed0_merge_pair.o \ + dlaed4_br.o dlaed7_br.o dlaed8_br.o dlaed9_br.o dstebr.o dsteqr_boundary_br.o endif ifdef USEXBLAS diff --git a/lapack-netlib/SRC/dlaed0_br.c b/lapack-netlib/SRC/dlaed0_br.c new file mode 100644 index 0000000000..3a7483b73d --- /dev/null +++ b/lapack-netlib/SRC/dlaed0_br.c @@ -0,0 +1,448 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef blasint logical; + +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* -- translated by f2c (version 20000121). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ + + +/* Table of constant values */ + +static integer c__9 = 9; +static integer c__0 = 0; +static integer c__14 = 14; +static integer c__1 = 1; + +/* > \brief \b DLAED0_BR used by DSTEBR. */ + +/* DLAED0_BR computes eigenvalues of a symmetric tridiagonal matrix with */ +/* the boundary-row divide-and-conquer method used by DSTEBR. Unlike */ +/* DLAED0(ICOMPQ=0), it keeps only first/last boundary rows for each */ +/* active block across merge levels instead of saving complete */ +/* eigenvector blocks. */ + +/* Serial Reference-LAPACK form: no OpenMP, environment-variable */ +/* scheduling, or thread-scaled workspace. */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \ingroup stebr */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science */ +/* > and Technology of China */ + +/* Subroutine */ void dlaed0_br_(integer *n, doublereal *d__, doublereal *e, + doublereal *work, integer *iwork, integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + doublereal d__1; + + /* Local variables */ + extern /* Subroutine */ void dlaed0_merge_pair_(integer *, integer *, + integer *, logical *, doublereal *, doublereal *, doublereal *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *, integer *, integer *, integer *, integer *, integer *, + integer *); + integer i__, j, k; + extern /* Subroutine */ void dsteqr_boundary_br_(integer *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, integer *); + integer msd2, smm1, spm1, ibhi, iblo, iscr, kdefl, qbase, merge, wbase, + infom; + extern /* Subroutine */ void dcopy_(integer *, doublereal *, integer *, + doublereal *, integer *); + integer indxq, iiwrk; + logical wantq; + integer iwbase, nmerge; + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer submat, subpbs, matsiz, smlsiz, wrkbase; + + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --iwork; + --work; + --e; + --d__; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLAED0_BR", &i__1, (ftnlen)9); + return; + } + + if (*n == 0) { + return; + } + + smlsiz = ilaenv_(&c__9, "DLAED0", " ", &c__0, &c__0, &c__0, &c__0, ( + ftnlen)6, (ftnlen)1); + +/* Determine the size and placement of leaf submatrices. */ + + iwork[1] = *n; + subpbs = 1; +L10: + if (iwork[subpbs] > smlsiz) { + for (j = subpbs; j >= 1; --j) { + iwork[j * 2] = (iwork[j] + 1) / 2; + iwork[(j << 1) - 1] = iwork[j] / 2; +/* L20: */ + } + subpbs <<= 1; + goto L10; + } + i__1 = subpbs; + for (j = 2; j <= i__1; ++j) { + iwork[j] += iwork[j - 1]; +/* L30: */ + } + +/* Apply rank-1 cuts. */ + + spm1 = subpbs - 1; + i__1 = spm1; + for (i__ = 1; i__ <= i__1; ++i__) { + submat = iwork[i__] + 1; + smm1 = submat - 1; + d__[smm1] -= (d__1 = e[smm1], abs(d__1)); + d__[submat] -= (d__1 = e[smm1], abs(d__1)); +/* L40: */ + } + +/* Workspace layout: */ +/* WORK(IBLO:IBLO+N-1) first boundary rows */ +/* WORK(IBHI:IBHI+N-1) last boundary rows */ +/* WORK(ISCR:) leaf scratch and per-merge scratch */ + +/* Integer workspace layout: */ +/* IWORK(1:N) split endpoints */ +/* IWORK(INDXQ:INDXQ+N-1) sorting permutations */ +/* IWORK(IIWRK:) DLAED7_BR scratch */ + + iblo = 1; + ibhi = iblo + *n; + iscr = ibhi + *n; + indxq = *n + 1; + iiwrk = indxq + *n; + +/* Solve leaf eigenproblems and initialize boundary row invariants. */ + + i__1 = subpbs; + for (i__ = 1; i__ <= i__1; ++i__) { + qbase = iscr; + wbase = qbase + smlsiz * smlsiz; + if (i__ == 1) { + submat = 1; + matsiz = iwork[1]; + } else { + submat = iwork[i__ - 1] + 1; + matsiz = iwork[i__] - iwork[i__ - 1]; + } + + dsteqr_boundary_br_(&matsiz, &d__[submat], &e[submat], &work[iblo + + submat - 1], &work[ibhi + submat - 1], &work[qbase], &smlsiz, + &work[wbase], info); + if (*info != 0) { + goto L130; + } + k = 1; + i__2 = iwork[i__]; + for (j = submat; j <= i__2; ++j) { + iwork[indxq + j - 1] = k; + ++k; +/* L65: */ + } +/* L70: */ + } + +/* Merge adjacent eigensystems. Boundary rows are updated in place */ +/* for the merged physical D order. */ + +L80: + if (subpbs > 1) { + wantq = subpbs > 2; + nmerge = subpbs / 2; + i__1 = nmerge; + for (merge = 1; merge <= i__1; ++merge) { + dlaed0_merge_pair_(&merge, &nmerge, &iwork[1], &wantq, &d__[1], & + e[1], &work[1], &iblo, &ibhi, &iscr, &iiwrk, &indxq, & + submat, &matsiz, &msd2, &wrkbase, &iwbase, &kdefl, &infom, + &c__14); + if (infom != 0) { + *info = infom; + goto L130; + } +/* L90: */ + } + + i__1 = nmerge; + for (merge = 1; merge <= i__1; ++merge) { + iwork[merge] = iwork[merge * 2]; +/* L95: */ + } + subpbs /= 2; + goto L80; + } + +/* Reorder eigenvalues from the final physical merge order. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + j = iwork[indxq + i__ - 1]; + work[iscr + i__ - 1] = d__[j]; +/* L100: */ + } + dcopy_(n, &work[iscr], &c__1, &d__[1], &c__1); + goto L140; + +L130: + *info = submat * (*n + 1) + submat + matsiz - 1; + +L140: + return; + +/* End of DLAED0_BR */ + +} /* dlaed0_br__ */ + diff --git a/lapack-netlib/SRC/dlaed0_br.f b/lapack-netlib/SRC/dlaed0_br.f new file mode 100644 index 0000000000..afbc6b7ff2 --- /dev/null +++ b/lapack-netlib/SRC/dlaed0_br.f @@ -0,0 +1,189 @@ +*> \brief \b DLAED0_BR used by DSTEBR. +* +* DLAED0_BR computes eigenvalues of a symmetric tridiagonal matrix with +* the boundary-row divide-and-conquer method used by DSTEBR. Unlike +* DLAED0(ICOMPQ=0), it keeps only first/last boundary rows for each +* active block across merge levels instead of saving complete +* eigenvector blocks. +* +* Serial Reference-LAPACK form: no OpenMP, environment-variable +* scheduling, or thread-scaled workspace. +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup stebr +* +*> \par Contributors: +* ================== +*> +*> Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science +*> and Technology of China +* + SUBROUTINE DLAED0_BR( N, D, E, WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. + INTEGER INFO, N +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION D( * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER WRKSTR + PARAMETER ( WRKSTR = 14 ) +* .. +* .. Local Scalars .. + LOGICAL WANTQ + INTEGER I, IBHI, IBLO, IIWRK, INDXQ, INFOM, ISCR, + $ IWBASE, J, K, KDEFL, MATSIZ, MERGE, MSD2, + $ NMERGE, QBASE, SMLSIZ, SMM1, SPM1, SUBMAT, + $ SUBPBS, WBASE, WRKBASE +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLAED0_MERGE_PAIR, + $ DSTEQR_BOUNDARY_BR, XERBLA +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLAED0_BR', -INFO ) + RETURN + END IF +* + IF( N.EQ.0 ) + $ RETURN +* + SMLSIZ = ILAENV( 9, 'DLAED0', ' ', 0, 0, 0, 0 ) +* +* Determine the size and placement of leaf submatrices. +* + IWORK( 1 ) = N + SUBPBS = 1 + 10 CONTINUE + IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN + DO 20 J = SUBPBS, 1, -1 + IWORK( 2*J ) = ( IWORK( J )+1 ) / 2 + IWORK( 2*J-1 ) = IWORK( J ) / 2 + 20 CONTINUE + SUBPBS = 2*SUBPBS + GO TO 10 + END IF + DO 30 J = 2, SUBPBS + IWORK( J ) = IWORK( J ) + IWORK( J-1 ) + 30 CONTINUE +* +* Apply rank-1 cuts. +* + SPM1 = SUBPBS - 1 + DO 40 I = 1, SPM1 + SUBMAT = IWORK( I ) + 1 + SMM1 = SUBMAT - 1 + D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) ) + D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) ) + 40 CONTINUE +* +* Workspace layout: +* WORK(IBLO:IBLO+N-1) first boundary rows +* WORK(IBHI:IBHI+N-1) last boundary rows +* WORK(ISCR:) leaf scratch and per-merge scratch +* +* Integer workspace layout: +* IWORK(1:N) split endpoints +* IWORK(INDXQ:INDXQ+N-1) sorting permutations +* IWORK(IIWRK:) DLAED7_BR scratch +* + IBLO = 1 + IBHI = IBLO + N + ISCR = IBHI + N + INDXQ = N + 1 + IIWRK = INDXQ + N +* +* Solve leaf eigenproblems and initialize boundary row invariants. +* + DO 70 I = 1, SUBPBS + QBASE = ISCR + WBASE = QBASE + SMLSIZ*SMLSIZ + IF( I.EQ.1 ) THEN + SUBMAT = 1 + MATSIZ = IWORK( 1 ) + ELSE + SUBMAT = IWORK( I-1 ) + 1 + MATSIZ = IWORK( I ) - IWORK( I-1 ) + END IF +* + CALL DSTEQR_BOUNDARY_BR( MATSIZ, D( SUBMAT ), E( SUBMAT ), + $ WORK( IBLO+SUBMAT-1 ), + $ WORK( IBHI+SUBMAT-1 ), + $ WORK( QBASE ), SMLSIZ, WORK( WBASE ), + $ INFO ) + IF( INFO.NE.0 ) + $ GO TO 130 + K = 1 + DO 65 J = SUBMAT, IWORK( I ) + IWORK( INDXQ+J-1 ) = K + K = K + 1 + 65 CONTINUE + 70 CONTINUE +* +* Merge adjacent eigensystems. Boundary rows are updated in place +* for the merged physical D order. +* + 80 CONTINUE + IF( SUBPBS.GT.1 ) THEN + WANTQ = SUBPBS.GT.2 + NMERGE = SUBPBS / 2 + DO 90 MERGE = 1, NMERGE + CALL DLAED0_MERGE_PAIR( MERGE, NMERGE, IWORK, WANTQ, D, E, + $ WORK, IBLO, IBHI, ISCR, IIWRK, INDXQ, SUBMAT, MATSIZ, + $ MSD2, WRKBASE, IWBASE, KDEFL, INFOM, WRKSTR ) + IF( INFOM.NE.0 ) THEN + INFO = INFOM + GO TO 130 + END IF + 90 CONTINUE +* + DO 95 MERGE = 1, NMERGE + IWORK( MERGE ) = IWORK( 2*MERGE ) + 95 CONTINUE + SUBPBS = SUBPBS / 2 + GO TO 80 + END IF +* +* Reorder eigenvalues from the final physical merge order. +* + DO 100 I = 1, N + J = IWORK( INDXQ+I-1 ) + WORK( ISCR+I-1 ) = D( J ) + 100 CONTINUE + CALL DCOPY( N, WORK( ISCR ), 1, D, 1 ) + GO TO 140 +* + 130 CONTINUE + INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1 +* + 140 CONTINUE + RETURN +* +* End of DLAED0_BR +* + END diff --git a/lapack-netlib/SRC/dlaed0_merge_pair.c b/lapack-netlib/SRC/dlaed0_merge_pair.c new file mode 100644 index 0000000000..44a36273d2 --- /dev/null +++ b/lapack-netlib/SRC/dlaed0_merge_pair.c @@ -0,0 +1,292 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef blasint logical; + +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* -- translated by f2c (version 20000121). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ + + +/* Table of constant values */ + +/* > \brief \b DLAED0_MERGE_PAIR executes one merge in the DC tree. */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \ingroup stebr */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science */ +/* > and Technology of China */ + +/* Subroutine */ void dlaed0_merge_pair_(integer *merge, integer *nmerge, + integer *iwork, logical *wantq, doublereal *d__, doublereal *e, + doublereal *work, integer *iblo, integer *ibhi, integer *iscr, + integer *iiwrk, integer *indxq, integer *submat, integer *matsiz, + integer *msd2, integer *wrkbase, integer *iwbase, integer *kdefl, + integer *info, integer *wrkstr) +{ + extern /* Subroutine */ void dlaed7_br_(logical *, integer *, integer *, + doublereal *, integer *, doublereal *, doublereal *, doublereal *, + doublereal *, integer *, integer *, integer *); + integer left, right; + + + + + /* Parameter adjustments */ + --work; + --e; + --d__; + --iwork; + + /* Function Body */ + left = (*merge << 1) - 1; + right = left + 1; + if (*merge == 1) { + *submat = 1; + *matsiz = iwork[right]; + *msd2 = iwork[1]; + } else { + *submat = iwork[left - 1] + 1; + *matsiz = iwork[right] - iwork[left - 1]; + *msd2 = iwork[left] - iwork[left - 1]; + } + + *wrkbase = *iscr + *wrkstr * (*submat - 1); + *iwbase = *iiwrk + (*submat - 1) * 5; + + dlaed7_br_(wantq, matsiz, msd2, &d__[*submat], &iwork[*indxq + *submat - + 1], &e[*submat + *msd2 - 1], &work[*iblo + *submat - 1], &work[* + ibhi + *submat - 1], &work[*wrkbase], &iwork[*iwbase], kdefl, + info); + return; +} /* dlaed0_merge_pair__ */ + diff --git a/lapack-netlib/SRC/dlaed0_merge_pair.f b/lapack-netlib/SRC/dlaed0_merge_pair.f new file mode 100644 index 0000000000..ea97a684be --- /dev/null +++ b/lapack-netlib/SRC/dlaed0_merge_pair.f @@ -0,0 +1,55 @@ +*> \brief \b DLAED0_MERGE_PAIR executes one merge in the DC tree. +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup stebr +* +*> \par Contributors: +* ================== +*> +*> Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science +*> and Technology of China +* + SUBROUTINE DLAED0_MERGE_PAIR( MERGE, NMERGE, IWORK, WANTQ, D, E, + $ WORK, IBLO, IBHI, ISCR, IIWRK, + $ INDXQ, SUBMAT, MATSIZ, MSD2, + $ WRKBASE, IWBASE, KDEFL, INFO, + $ WRKSTR ) +* + INTEGER IBHI, IBLO, IIWRK, INDXQ, INFO, ISCR, IWBASE, + $ KDEFL, MATSIZ, MERGE, MSD2, NMERGE, RIGHT, + $ SUBMAT, WRKBASE, WRKSTR + LOGICAL WANTQ + INTEGER IWORK( * ) + DOUBLE PRECISION D( * ), E( * ), WORK( * ) + EXTERNAL DLAED7_BR +* + INTEGER LEFT +* + LEFT = 2*MERGE - 1 + RIGHT = LEFT + 1 + IF( MERGE.EQ.1 ) THEN + SUBMAT = 1 + MATSIZ = IWORK( RIGHT ) + MSD2 = IWORK( 1 ) + ELSE + SUBMAT = IWORK( LEFT-1 ) + 1 + MATSIZ = IWORK( RIGHT ) - IWORK( LEFT-1 ) + MSD2 = IWORK( LEFT ) - IWORK( LEFT-1 ) + END IF +* + WRKBASE = ISCR + WRKSTR*( SUBMAT-1 ) + IWBASE = IIWRK + 5*( SUBMAT-1 ) +* + CALL DLAED7_BR( WANTQ, MATSIZ, MSD2, D( SUBMAT ), + $ IWORK( INDXQ+SUBMAT-1 ), E( SUBMAT+MSD2-1 ), + $ WORK( IBLO+SUBMAT-1 ), WORK( IBHI+SUBMAT-1 ), + $ WORK( WRKBASE ), IWORK( IWBASE ), KDEFL, INFO ) + RETURN + END diff --git a/lapack-netlib/SRC/dlaed4_br.c b/lapack-netlib/SRC/dlaed4_br.c new file mode 100644 index 0000000000..7d2e3f1f44 --- /dev/null +++ b/lapack-netlib/SRC/dlaed4_br.c @@ -0,0 +1,356 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef blasint logical; + +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* -- translated by f2c (version 20000121). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ + + +/* Table of constant values */ + + +/* > \brief \b DLAED4_BR used by DSTEBR. */ + +/* DLAED4_BR computes one secular root with DLAED4 and exposes a compact */ +/* representation of the returned high-relative-accuracy DELTA vector. */ +/* For N > 2, DLAED4's DELTA entries are all relative to either D(I) */ +/* or D(I+1), except for the final root where the origin is D(N). */ +/* ORG records that origin index and TAU satisfies */ + +/* lambda = D(ORG) + TAU, */ +/* DELTA(j) = D(j) - D(ORG) - TAU. */ + +/* NEAR1/NEAR2 cache the two pole-adjacent DELTA entries that are most */ +/* sensitive to cancellation when reconstructed from D and TAU. */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \ingroup stebr */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science */ +/* > and Technology of China */ + +/* Subroutine */ void dlaed4_br_(integer *n, integer *i__, doublereal *d__, + doublereal *z__, doublereal *delta, doublereal *rho, doublereal *dlam, + integer *org, doublereal *tau, doublereal *near1, doublereal *near2, + integer *info) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + doublereal mid; + extern /* Subroutine */ void dlaed4_(integer *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *) + , xerbla_(char *, integer *, ftnlen); + + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --delta; + --z__; + --d__; + + /* Function Body */ + *info = 0; + *org = 1; + *tau = 0.; + *near1 = 0.; + *near2 = 0.; + + if (*n < 1) { + *info = -1; + } else if (*i__ < 1 || *i__ > *n) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLAED4_BR", &i__1, (ftnlen)9); + return; + } + + dlaed4_(n, i__, &d__[1], &z__[1], &delta[1], rho, dlam, info); + if (*info != 0) { + return; + } + + if (*n == 1) { + *org = 1; + *tau = *dlam - d__[1]; + *near1 = delta[1]; + *near2 = 0.; + return; + } + + if (*n == 2) { + *org = 1; + *tau = *dlam - d__[1]; + *near1 = delta[1]; + *near2 = delta[2]; + return; + } + + if (*i__ == *n) { + *org = *n; + } else { + mid = (d__[*i__] + d__[*i__ + 1]) * .5; + if (*dlam < mid) { + *org = *i__; + } else { + *org = *i__ + 1; + } + } + +/* Avoid reconstructing TAU from DLAM-D(ORG). DLAED4 already */ +/* returned DELTA(ORG) in its shifted coordinate, so using */ +/* TAU=-DELTA(ORG) preserves that final rounded denominator and */ +/* avoids an extra add/subtract rounding through DLAM. */ + + *tau = -delta[*org]; + + if (*i__ == *n) { + *near1 = delta[*n - 1]; + *near2 = delta[*n]; + } else { + *near1 = delta[*i__]; + *near2 = delta[*i__ + 1]; + } + + return; + +/* End of DLAED4_BR */ + +} /* dlaed4_br__ */ + diff --git a/lapack-netlib/SRC/dlaed4_br.f b/lapack-netlib/SRC/dlaed4_br.f new file mode 100644 index 0000000000..1d51cbca0b --- /dev/null +++ b/lapack-netlib/SRC/dlaed4_br.f @@ -0,0 +1,125 @@ +*> \brief \b DLAED4_BR used by DSTEBR. +* +* DLAED4_BR computes one secular root with DLAED4 and exposes a compact +* representation of the returned high-relative-accuracy DELTA vector. +* For N > 2, DLAED4's DELTA entries are all relative to either D(I) +* or D(I+1), except for the final root where the origin is D(N). +* ORG records that origin index and TAU satisfies +* +* lambda = D(ORG) + TAU, +* DELTA(j) = D(j) - D(ORG) - TAU. +* +* NEAR1/NEAR2 cache the two pole-adjacent DELTA entries that are most +* sensitive to cancellation when reconstructed from D and TAU. +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup stebr +* +*> \par Contributors: +* ================== +*> +*> Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science +*> and Technology of China +* + SUBROUTINE DLAED4_BR( N, I, D, Z, DELTA, RHO, DLAM, ORG, + $ TAU, NEAR1, NEAR2, INFO ) +* +* .. Scalar Arguments .. + INTEGER I, INFO, N, ORG + DOUBLE PRECISION DLAM, NEAR1, NEAR2, RHO, TAU +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), DELTA( * ), Z( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION HALF, ZERO + PARAMETER ( HALF = 0.5D0, ZERO = 0.0D0 ) +* .. +* .. Local Scalars .. + DOUBLE PRECISION MID +* .. +* .. External Subroutines .. + EXTERNAL DLAED4, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. +* + INFO = 0 + ORG = 1 + TAU = ZERO + NEAR1 = ZERO + NEAR2 = ZERO +* + IF( N.LT.1 ) THEN + INFO = -1 + ELSE IF( I.LT.1 .OR. I.GT.N ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLAED4_BR', -INFO ) + RETURN + END IF +* + CALL DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO ) + IF( INFO.NE.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + ORG = 1 + TAU = DLAM - D( 1 ) + NEAR1 = DELTA( 1 ) + NEAR2 = ZERO + RETURN + END IF +* + IF( N.EQ.2 ) THEN + ORG = 1 + TAU = DLAM - D( 1 ) + NEAR1 = DELTA( 1 ) + NEAR2 = DELTA( 2 ) + RETURN + END IF +* + IF( I.EQ.N ) THEN + ORG = N + ELSE + MID = HALF*( D( I )+D( I+1 ) ) + IF( DLAM.LT.MID ) THEN + ORG = I + ELSE + ORG = I + 1 + END IF + END IF +* +* Avoid reconstructing TAU from DLAM-D(ORG). DLAED4 already +* returned DELTA(ORG) in its shifted coordinate, so using +* TAU=-DELTA(ORG) preserves that final rounded denominator and +* avoids an extra add/subtract rounding through DLAM. +* + TAU = -DELTA( ORG ) +* + IF( I.EQ.N ) THEN + NEAR1 = DELTA( N-1 ) + NEAR2 = DELTA( N ) + ELSE + NEAR1 = DELTA( I ) + NEAR2 = DELTA( I+1 ) + END IF +* + RETURN +* +* End of DLAED4_BR +* + END diff --git a/lapack-netlib/SRC/dlaed7_br.c b/lapack-netlib/SRC/dlaed7_br.c new file mode 100644 index 0000000000..a84dde5891 --- /dev/null +++ b/lapack-netlib/SRC/dlaed7_br.c @@ -0,0 +1,434 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef blasint logical; + +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* -- translated by f2c (version 20000121). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ + + +/* Table of constant values */ + +static integer c__2 = 2; +static integer c__1 = 1; +static integer c_n1 = -1; + +/* > \brief \b DLAED7_BR used by DSTEBR. */ + +/* DLAED7_BR performs one divide-and-conquer merge while propagating */ +/* only the first and last rows of the current local eigenvector block. */ +/* It is called by DLAED0_BR and is not itself a public LAPACK API. */ + +/* Serial Reference-LAPACK form: no OpenMP or thread-scaled workspace. */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \ingroup stebr */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science */ +/* > and Technology of China */ + +/* Subroutine */ void dlaed7_br_(logical *wantq, integer *n, integer *cutpnt, + doublereal *d__, integer *indxq, doublereal *rho, doublereal *blo, + doublereal *bhi, doublereal *work, integer *iwork, integer *kdefl, + integer *info) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + extern /* Subroutine */ void dlaed8_br_(integer *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, doublereal *, doublereal *, doublereal *, integer *, + doublereal *, integer *, integer *, integer *, doublereal *, + integer *, integer *, integer *), dlaed9_br_(integer *, integer * + , doublereal *, doublereal *, integer *, doublereal *, integer *, + doublereal *, doublereal *, doublereal *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *) + ; + integer i__, j, k, n1, n2, iq, iw, iz, iq2, nbr, iscr, itau, inear, iindx, + iperm, iwsgn, idlmda; + extern /* Subroutine */ void dlamrg_(integer *, integer *, doublereal *, + integer *, integer *, integer *); + integer igivcl; + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); + integer igivnm, iindxp, givptr; + + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --iwork; + --work; + --bhi; + --blo; + --indxq; + --d__; + + /* Function Body */ + *info = 0; + *kdefl = 0; + if (*n < 0) { + *info = -1; + } else if (*cutpnt < f2cmin(1,*n) || *cutpnt > *n) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLAED7_BR", &i__1, (ftnlen)9); + return; + } + + if (*n == 0) { + return; + } + +/* Workspace layout (14*N doubles): */ + +/* Z, DLAMBDA, W : N each */ +/* QBR, Q2BR, GIVNUM/reused WPROD : 2*N each */ +/* DELTA, WSGN, TAU, NEAR : N, N, N, 2*N */ + + iz = 1; + idlmda = iz + *n; + iw = idlmda + *n; + iq = iw + *n; + iq2 = iq + (*n << 1); + igivnm = iq2 + (*n << 1); + iscr = igivnm + (*n << 1); + iwsgn = iscr + *n; + itau = iwsgn + *n; + inear = itau + *n; + +/* Integer workspace layout. */ + + iindxp = 1; + iindx = iindxp + *n; + iperm = iindx + *n; + igivcl = iperm + *n; + + if (*wantq) { + nbr = 2; + } else { + nbr = 0; + } + +/* Z is the rank-one update vector. QBR has two selected rows of */ +/* blockdiag(Q_left,Q_right): parent first boundary and parent last */ +/* boundary, represented in the child eigenbases. The root merge has */ +/* no parent, so it only needs Z for the secular eigenvalues. */ + + if (*wantq) { + i__1 = *cutpnt; + for (j = 1; j <= i__1; ++j) { + work[iz + j - 1] = bhi[j]; + work[iq + (j - 1 << 1)] = blo[j]; + work[iq + (j - 1 << 1) + 1] = 0.; +/* L20: */ + } + i__1 = *n; + for (j = *cutpnt + 1; j <= i__1; ++j) { + work[iz + j - 1] = blo[j]; + work[iq + (j - 1 << 1)] = 0.; + work[iq + (j - 1 << 1) + 1] = bhi[j]; +/* L30: */ + } + } else { + i__1 = *cutpnt; + for (j = 1; j <= i__1; ++j) { + work[iz + j - 1] = bhi[j]; +/* L40: */ + } + i__1 = *n; + for (j = *cutpnt + 1; j <= i__1; ++j) { + work[iz + j - 1] = blo[j]; +/* L50: */ + } + } + +/* Sort and deflate, applying the same Givens/permutation actions to */ +/* the selected boundary rows when a parent merge will need them. */ + + + dlaed8_br_(&nbr, &k, n, &d__[1], &work[iq], &c__2, &indxq[1], rho, + cutpnt, &work[iz], &work[idlmda], &work[iq2], &c__2, &work[iw], & + iwork[iperm], &givptr, &iwork[igivcl], &work[igivnm], &iwork[ + iindxp], &iwork[iindx], info); + if (*info != 0) { + goto L70; + } + *kdefl = k; + +/* Solve the secular equation and directly update the selected rows. */ +/* WORK(ISCR) holds one DLAED4 delta vector at a time; no K-by-K */ +/* delta or eigenvector block is materialized. */ + + if (k != 0) { + dlaed9_br_(&k, &nbr, &d__[1], &work[iq2], &c__2, &work[iq], &c__2, + rho, &work[idlmda], &work[iw], &work[iscr], &work[igivnm], & + work[iwsgn], &work[itau], &work[inear], info); + if (*info != 0) { + goto L70; + } + +/* Prepare INDXQ sorting permutation. */ + + n1 = k; + n2 = *n - k; + dlamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]); + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + indxq[i__] = i__; +/* L60: */ + } + } + +/* Persist the parent boundary rows in the current physical D order. */ + + if (*wantq) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + blo[j] = work[iq + (j - 1 << 1)]; + bhi[j] = work[iq + (j - 1 << 1) + 1]; +/* L65: */ + } + } + +L70: + return; + +/* End of DLAED7_BR */ + +} /* dlaed7_br__ */ + diff --git a/lapack-netlib/SRC/dlaed7_br.f b/lapack-netlib/SRC/dlaed7_br.f new file mode 100644 index 0000000000..30a98e573c --- /dev/null +++ b/lapack-netlib/SRC/dlaed7_br.f @@ -0,0 +1,178 @@ +*> \brief \b DLAED7_BR used by DSTEBR. +* +* DLAED7_BR performs one divide-and-conquer merge while propagating +* only the first and last rows of the current local eigenvector block. +* It is called by DLAED0_BR and is not itself a public LAPACK API. +* +* Serial Reference-LAPACK form: no OpenMP or thread-scaled workspace. +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup stebr +* +*> \par Contributors: +* ================== +*> +*> Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science +*> and Technology of China +* + SUBROUTINE DLAED7_BR( WANTQ, N, CUTPNT, D, INDXQ, RHO, BLO, BHI, + $ WORK, IWORK, KDEFL, INFO ) +* +* .. Scalar Arguments .. + LOGICAL WANTQ + INTEGER CUTPNT, INFO, KDEFL, N + DOUBLE PRECISION RHO +* .. +* .. Array Arguments .. + INTEGER INDXQ( * ), IWORK( * ) + DOUBLE PRECISION BLO( * ), BHI( * ), D( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO + PARAMETER ( ZERO = 0.0D0 ) +* .. +* .. Local Scalars .. + INTEGER GIVPTR, IDLMDA, IGIVCL, IGIVNM, I, IINDX, + $ IINDXP, INEAR, IPERM, IQ, IQ2, ISCR, ITAU, IW, + $ IWSGN, IZ, J, K, N1, N2, NBR +* .. +* .. External Subroutines .. + EXTERNAL DLAED8_BR, DLAED9_BR, DLAMRG, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + KDEFL = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLAED7_BR', -INFO ) + RETURN + END IF +* + IF( N.EQ.0 ) + $ RETURN +* +* Workspace layout (14*N doubles): +* +* Z, DLAMBDA, W : N each +* QBR, Q2BR, GIVNUM/reused WPROD : 2*N each +* DELTA, WSGN, TAU, NEAR : N, N, N, 2*N +* + IZ = 1 + IDLMDA = IZ + N + IW = IDLMDA + N + IQ = IW + N + IQ2 = IQ + 2*N + IGIVNM = IQ2 + 2*N + ISCR = IGIVNM + 2*N + IWSGN = ISCR + N + ITAU = IWSGN + N + INEAR = ITAU + N +* +* Integer workspace layout. +* + IINDXP = 1 + IINDX = IINDXP + N + IPERM = IINDX + N + IGIVCL = IPERM + N +* + IF( WANTQ ) THEN + NBR = 2 + ELSE + NBR = 0 + END IF +* +* Z is the rank-one update vector. QBR has two selected rows of +* blockdiag(Q_left,Q_right): parent first boundary and parent last +* boundary, represented in the child eigenbases. The root merge has +* no parent, so it only needs Z for the secular eigenvalues. +* + IF( WANTQ ) THEN + DO 20 J = 1, CUTPNT + WORK( IZ+J-1 ) = BHI( J ) + WORK( IQ+2*( J-1 ) ) = BLO( J ) + WORK( IQ+2*( J-1 )+1 ) = ZERO + 20 CONTINUE + DO 30 J = CUTPNT + 1, N + WORK( IZ+J-1 ) = BLO( J ) + WORK( IQ+2*( J-1 ) ) = ZERO + WORK( IQ+2*( J-1 )+1 ) = BHI( J ) + 30 CONTINUE + ELSE + DO 40 J = 1, CUTPNT + WORK( IZ+J-1 ) = BHI( J ) + 40 CONTINUE + DO 50 J = CUTPNT + 1, N + WORK( IZ+J-1 ) = BLO( J ) + 50 CONTINUE + END IF +* +* Sort and deflate, applying the same Givens/permutation actions to +* the selected boundary rows when a parent merge will need them. +* +* + CALL DLAED8_BR( NBR, K, N, D, WORK( IQ ), 2, INDXQ, RHO, + $ CUTPNT, WORK( IZ ), WORK( IDLMDA ), + $ WORK( IQ2 ), 2, WORK( IW ), IWORK( IPERM ), + $ GIVPTR, IWORK( IGIVCL ), WORK( IGIVNM ), + $ IWORK( IINDXP ), IWORK( IINDX ), INFO ) + IF( INFO.NE.0 ) + $ GO TO 70 + KDEFL = K +* +* Solve the secular equation and directly update the selected rows. +* WORK(ISCR) holds one DLAED4 delta vector at a time; no K-by-K +* delta or eigenvector block is materialized. +* + IF( K.NE.0 ) THEN + CALL DLAED9_BR( K, NBR, D, WORK( IQ2 ), 2, WORK( IQ ), 2, + $ RHO, WORK( IDLMDA ), WORK( IW ), + $ WORK( ISCR ), WORK( IGIVNM ), + $ WORK( IWSGN ), WORK( ITAU ), + $ WORK( INEAR ), INFO ) + IF( INFO.NE.0 ) + $ GO TO 70 +* +* Prepare INDXQ sorting permutation. +* + N1 = K + N2 = N - K + CALL DLAMRG( N1, N2, D, 1, -1, INDXQ ) + ELSE + DO 60 I = 1, N + INDXQ( I ) = I + 60 CONTINUE + END IF +* +* Persist the parent boundary rows in the current physical D order. +* + IF( WANTQ ) THEN + DO 65 J = 1, N + BLO( J ) = WORK( IQ+2*( J-1 ) ) + BHI( J ) = WORK( IQ+2*( J-1 )+1 ) + 65 CONTINUE + END IF +* + 70 CONTINUE + RETURN +* +* End of DLAED7_BR +* + END diff --git a/lapack-netlib/SRC/dlaed8_br.c b/lapack-netlib/SRC/dlaed8_br.c new file mode 100644 index 0000000000..b3794652ad --- /dev/null +++ b/lapack-netlib/SRC/dlaed8_br.c @@ -0,0 +1,502 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef blasint logical; + +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* -- translated by f2c (version 20000121). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ + + +/* Table of constant values */ + +static doublereal c_b3 = -1.; +static integer c__1 = 1; + +/* > \brief \b DLAED8_BR selected-row variant of DLAED8. */ + +/* DLAED8_BR mirrors DLAED8 deflation and bookkeeping but applies the */ +/* column rotations/permutations to NBR selected rows rather than to a */ +/* full eigenvector matrix. It is an internal helper for DLAED7_BR. */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \ingroup stebr */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science */ +/* > and Technology of China */ + +/* Subroutine */ void dlaed8_br_(integer *nbr, integer *k, integer *n, + doublereal *d__, doublereal *q, integer *ldq, integer *indxq, + doublereal *rho, integer *cutpnt, doublereal *z__, doublereal * + dlambda, doublereal *q2, integer *ldq2, doublereal *w, integer *perm, + integer *givptr, integer *givcol, doublereal *givnum, integer *indxp, + integer *indx, integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, q2_dim1, q2_offset, i__1; + doublereal d__1; + + /* Local variables */ + doublereal c__; + integer i__, j; + doublereal s, t; + integer k2, n1, n2, jp, n1p1; + doublereal eps, tau, tol; + integer jlam, imax, jmax; + extern /* Subroutine */ void drot_(integer *, doublereal *, integer *, + doublereal *, integer *, doublereal *, doublereal *), dscal_( + integer *, doublereal *, doublereal *, integer *), dcopy_(integer + *, doublereal *, integer *, doublereal *, integer *); + extern doublereal dlapy2_(doublereal *, doublereal *), dlamch_(char *); + extern integer idamax_(integer *, doublereal *, integer *); + extern /* Subroutine */ void dlamrg_(integer *, integer *, doublereal *, + integer *, integer *, integer *), dlacpy_(char *, integer *, + integer *, doublereal *, integer *, doublereal *, integer *), xerbla_(char *, integer *, ftnlen); + + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --d__; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + --indxq; + --z__; + --dlambda; + q2_dim1 = *ldq2; + q2_offset = 1 + q2_dim1; + q2 -= q2_offset; + --w; + --perm; + givcol -= 3; + givnum -= 3; + --indxp; + --indx; + + /* Function Body */ + *info = 0; + if (*nbr < 0) { + *info = -1; + } else if (*n < 0) { + *info = -3; + } else if (*ldq < f2cmax(1,*nbr)) { + *info = -6; + } else if (*cutpnt < f2cmin(1,*n) || *cutpnt > *n) { + *info = -9; + } else if (*ldq2 < f2cmax(1,*nbr)) { + *info = -13; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLAED8_BR", &i__1, (ftnlen)9); + return; + } + + *givptr = 0; + if (*n == 0) { + return; + } + + n1 = *cutpnt; + n2 = *n - n1; + n1p1 = n1 + 1; + + if (*rho < 0.) { + dscal_(&n2, &c_b3, &z__[n1p1], &c__1); + } + + t = 1. / sqrt(2.); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + indx[j] = j; +/* L80: */ + } + dscal_(n, &t, &z__[1], &c__1); + *rho = (d__1 = *rho * 2., abs(d__1)); + +/* Sort the eigenvalues into increasing order. */ + + i__1 = *n; + for (i__ = *cutpnt + 1; i__ <= i__1; ++i__) { + indxq[i__] += *cutpnt; +/* L90: */ + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dlambda[i__] = d__[indxq[i__]]; + w[i__] = z__[indxq[i__]]; +/* L100: */ + } + dlamrg_(&n1, &n2, &dlambda[1], &c__1, &c__1, &indx[1]); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = dlambda[indx[i__]]; + z__[i__] = w[indx[i__]]; +/* L110: */ + } + + imax = idamax_(n, &z__[1], &c__1); + jmax = idamax_(n, &d__[1], &c__1); + eps = dlamch_("Epsilon"); + tol = eps * 8. * (d__1 = d__[jmax], abs(d__1)); + + if (*rho * (d__1 = z__[imax], abs(d__1)) <= tol) { + *k = 0; + if (*nbr == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + perm[j] = indxq[indx[j]]; +/* L115: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + perm[j] = indxq[indx[j]]; + dcopy_(nbr, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + + 1], &c__1); +/* L120: */ + } + dlacpy_("A", nbr, n, &q2[q2_offset], ldq2, &q[q_offset], ldq); + } + return; + } + + *k = 0; + k2 = *n + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) { + --k2; + indxp[k2] = j; + if (j == *n) { + goto L170; + } + } else { + jlam = j; + goto L140; + } +/* L130: */ + } +L140: + ++j; + if (j > *n) { + goto L160; + } + if (*rho * (d__1 = z__[j], abs(d__1)) <= tol) { + --k2; + indxp[k2] = j; + } else { + s = z__[jlam]; + c__ = z__[j]; + tau = dlapy2_(&c__, &s); + t = d__[j] - d__[jlam]; + c__ /= tau; + s = -s / tau; + if ((d__1 = t * c__ * s, abs(d__1)) <= tol) { + z__[j] = tau; + z__[jlam] = 0.; + + ++(*givptr); + givcol[(*givptr << 1) + 1] = indxq[indx[jlam]]; + givcol[(*givptr << 1) + 2] = indxq[indx[j]]; + givnum[(*givptr << 1) + 1] = c__; + givnum[(*givptr << 1) + 2] = s; + if (*nbr != 0) { + drot_(nbr, &q[indxq[indx[jlam]] * q_dim1 + 1], &c__1, &q[ + indxq[indx[j]] * q_dim1 + 1], &c__1, &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; + i__ = 1; +L150: + if (k2 + i__ <= *n) { + if (d__[jlam] < d__[indxp[k2 + i__]]) { + indxp[k2 + i__ - 1] = indxp[k2 + i__]; + indxp[k2 + i__] = jlam; + ++i__; + goto L150; + } else { + indxp[k2 + i__ - 1] = jlam; + } + } else { + indxp[k2 + i__ - 1] = jlam; + } + jlam = j; + } else { + ++(*k); + w[*k] = z__[jlam]; + dlambda[*k] = d__[jlam]; + indxp[*k] = jlam; + jlam = j; + } + } + goto L140; +L160: + + ++(*k); + w[*k] = z__[jlam]; + dlambda[*k] = d__[jlam]; + indxp[*k] = jlam; + +L170: + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jp = indxp[j]; + dlambda[j] = d__[jp]; + perm[j] = indxq[indx[jp]]; + if (*nbr != 0) { + dcopy_(nbr, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1], + &c__1); + } +/* L180: */ + } + + if (*k < *n) { + i__1 = *n - *k; + dcopy_(&i__1, &dlambda[*k + 1], &c__1, &d__[*k + 1], &c__1); + if (*nbr != 0) { + i__1 = *n - *k; + dlacpy_("A", nbr, &i__1, &q2[(*k + 1) * q2_dim1 + 1], ldq2, &q[(* + k + 1) * q_dim1 + 1], ldq); + } + } + + return; + +/* End of DLAED8_BR */ + +} /* dlaed8_br__ */ + diff --git a/lapack-netlib/SRC/dlaed8_br.f b/lapack-netlib/SRC/dlaed8_br.f new file mode 100644 index 0000000000..a2c1ad7842 --- /dev/null +++ b/lapack-netlib/SRC/dlaed8_br.f @@ -0,0 +1,229 @@ +*> \brief \b DLAED8_BR selected-row variant of DLAED8. +* +* DLAED8_BR mirrors DLAED8 deflation and bookkeeping but applies the +* column rotations/permutations to NBR selected rows rather than to a +* full eigenvector matrix. It is an internal helper for DLAED7_BR. +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup stebr +* +*> \par Contributors: +* ================== +*> +*> Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science +*> and Technology of China +* + SUBROUTINE DLAED8_BR( NBR, K, N, D, Q, LDQ, INDXQ, RHO, + $ CUTPNT, Z, DLAMBDA, Q2, LDQ2, W, PERM, + $ GIVPTR, GIVCOL, GIVNUM, INDXP, INDX, + $ INFO ) +* +* .. Scalar Arguments .. + INTEGER CUTPNT, GIVPTR, INFO, K, LDQ, LDQ2, N, NBR + DOUBLE PRECISION RHO +* .. +* .. Array Arguments .. + INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ), + $ INDXQ( * ), PERM( * ) + DOUBLE PRECISION D( * ), DLAMBDA( * ), GIVNUM( 2, * ), + $ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT + PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, + $ ONE = 1.0D0, TWO = 2.0D0, EIGHT = 8.0D0 ) +* .. +* .. Local Scalars .. + INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2 + DOUBLE PRECISION C, EPS, S, T, TAU, TOL +* .. +* .. External Functions .. + INTEGER IDAMAX + DOUBLE PRECISION DLAMCH, DLAPY2 + EXTERNAL IDAMAX, DLAMCH, DLAPY2 +* .. +* .. External Subroutines .. + EXTERNAL DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + INFO = 0 + IF( NBR.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDQ.LT.MAX( 1, NBR ) ) THEN + INFO = -6 + ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN + INFO = -9 + ELSE IF( LDQ2.LT.MAX( 1, NBR ) ) THEN + INFO = -13 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLAED8_BR', -INFO ) + RETURN + END IF +* + GIVPTR = 0 + IF( N.EQ.0 ) + $ RETURN +* + N1 = CUTPNT + N2 = N - N1 + N1P1 = N1 + 1 +* + IF( RHO.LT.ZERO ) THEN + CALL DSCAL( N2, MONE, Z( N1P1 ), 1 ) + END IF +* + T = ONE / SQRT( TWO ) + DO 80 J = 1, N + INDX( J ) = J + 80 CONTINUE + CALL DSCAL( N, T, Z, 1 ) + RHO = ABS( TWO*RHO ) +* +* Sort the eigenvalues into increasing order. +* + DO 90 I = CUTPNT + 1, N + INDXQ( I ) = INDXQ( I ) + CUTPNT + 90 CONTINUE + DO 100 I = 1, N + DLAMBDA( I ) = D( INDXQ( I ) ) + W( I ) = Z( INDXQ( I ) ) + 100 CONTINUE + CALL DLAMRG( N1, N2, DLAMBDA, 1, 1, INDX ) + DO 110 I = 1, N + D( I ) = DLAMBDA( INDX( I ) ) + Z( I ) = W( INDX( I ) ) + 110 CONTINUE +* + IMAX = IDAMAX( N, Z, 1 ) + JMAX = IDAMAX( N, D, 1 ) + EPS = DLAMCH( 'Epsilon' ) + TOL = EIGHT*EPS*ABS( D( JMAX ) ) +* + IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN + K = 0 + IF( NBR.EQ.0 ) THEN + DO 115 J = 1, N + PERM( J ) = INDXQ( INDX( J ) ) + 115 CONTINUE + ELSE + DO 120 J = 1, N + PERM( J ) = INDXQ( INDX( J ) ) + CALL DCOPY( NBR, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 ) + 120 CONTINUE + CALL DLACPY( 'A', NBR, N, Q2, LDQ2, Q, LDQ ) + END IF + RETURN + END IF +* + K = 0 + K2 = N + 1 + DO 130 J = 1, N + IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN + K2 = K2 - 1 + INDXP( K2 ) = J + IF( J.EQ.N ) + $ GO TO 170 + ELSE + JLAM = J + GO TO 140 + END IF + 130 CONTINUE + 140 CONTINUE + J = J + 1 + IF( J.GT.N ) + $ GO TO 160 + IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN + K2 = K2 - 1 + INDXP( K2 ) = J + ELSE + S = Z( JLAM ) + C = Z( J ) + TAU = DLAPY2( C, S ) + T = D( J ) - D( JLAM ) + C = C / TAU + S = -S / TAU + IF( ABS( T*C*S ).LE.TOL ) THEN + Z( J ) = TAU + Z( JLAM ) = ZERO +* + GIVPTR = GIVPTR + 1 + GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) ) + GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) ) + GIVNUM( 1, GIVPTR ) = C + GIVNUM( 2, GIVPTR ) = S + IF( NBR.NE.0 ) + $ CALL DROT( NBR, Q( 1, INDXQ( INDX( JLAM ) ) ), 1, + $ Q( 1, INDXQ( INDX( J ) ) ), 1, 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 + 150 CONTINUE + IF( K2+I.LE.N ) THEN + IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN + INDXP( K2+I-1 ) = INDXP( K2+I ) + INDXP( K2+I ) = JLAM + I = I + 1 + GO TO 150 + ELSE + INDXP( K2+I-1 ) = JLAM + END IF + ELSE + INDXP( K2+I-1 ) = JLAM + END IF + JLAM = J + ELSE + K = K + 1 + W( K ) = Z( JLAM ) + DLAMBDA( K ) = D( JLAM ) + INDXP( K ) = JLAM + JLAM = J + END IF + END IF + GO TO 140 + 160 CONTINUE +* + K = K + 1 + W( K ) = Z( JLAM ) + DLAMBDA( K ) = D( JLAM ) + INDXP( K ) = JLAM +* + 170 CONTINUE + DO 180 J = 1, N + JP = INDXP( J ) + DLAMBDA( J ) = D( JP ) + PERM( J ) = INDXQ( INDX( JP ) ) + IF( NBR.NE.0 ) + $ CALL DCOPY( NBR, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 ) + 180 CONTINUE +* + IF( K.LT.N ) THEN + CALL DCOPY( N-K, DLAMBDA( K+1 ), 1, D( K+1 ), 1 ) + IF( NBR.NE.0 ) + $ CALL DLACPY( 'A', NBR, N-K, Q2( 1, K+1 ), LDQ2, + $ Q( 1, K+1 ), LDQ ) + END IF +* + RETURN +* +* End of DLAED8_BR +* + END diff --git a/lapack-netlib/SRC/dlaed9_br.c b/lapack-netlib/SRC/dlaed9_br.c new file mode 100644 index 0000000000..81f2f2cb25 --- /dev/null +++ b/lapack-netlib/SRC/dlaed9_br.c @@ -0,0 +1,552 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef blasint logical; + +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* -- translated by f2c (version 20000121). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ + +/* > \brief \b DLAED9_BR used by DSTEBR. */ + +/* DLAED9_BR finds the roots of the secular equation for one */ +/* boundary-row DC merge and directly updates a small set of selected */ +/* rows. It mirrors DLAED9's root solve and eigenvector normalization, */ +/* but avoids materializing the full K-by-K secular eigenvector block. */ +/* DLAED4_BR returns high-relative-accuracy DELTA values for each root; */ +/* consume those DELTA values immediately to form WPROD, following the */ +/* same numerical idea as LAPACK's SVD divide-and-conquer helpers. */ + +/* Serial Reference-LAPACK form: no OpenMP or thread-private */ +/* accumulators. */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \ingroup stebr */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science */ +/* > and Technology of China */ + +/* Subroutine */ void dlaed9_br_(integer *k, integer *nbr, doublereal *d__, + doublereal *qin, integer *ldqin, doublereal *qout, integer *ldqout, + doublereal *rho, doublereal *dlambda, doublereal *w, doublereal * + delta, doublereal *wprod, doublereal *wsgn, doublereal *tau, + doublereal *near__, integer *info) +{ + /* System generated locals */ + integer qin_dim1, qin_offset, qout_dim1, qout_offset, i__1, i__2, i__3; + doublereal d__1; + + /* Local variables */ + extern /* Subroutine */ void dlaed4_br_(integer *, integer *, doublereal * + , doublereal *, doublereal *, doublereal *, doublereal *, integer + *, doublereal *, doublereal *, doublereal *, integer *); + integer i__, j, r__, n1, n2; + doublereal dlt, acc1, acc2; + integer iorg; + doublereal temp; + extern /* Subroutine */ void dlaed4_(integer *, integer *, doublereal *, + doublereal *, doublereal *, doublereal *, doublereal *, integer *) + , xerbla_(char *, integer *, ftnlen); + doublereal rowsum; + + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --d__; + qin_dim1 = *ldqin; + qin_offset = 1 + qin_dim1; + qin -= qin_offset; + qout_dim1 = *ldqout; + qout_offset = 1 + qout_dim1; + qout -= qout_offset; + --dlambda; + --w; + --delta; + --wprod; + --wsgn; + --tau; + near__ -= 3; + + /* Function Body */ + *info = 0; + if (*k < 0) { + *info = -1; + } else if (*nbr < 0) { + *info = -2; + } else if (*ldqin < f2cmax(1,*nbr)) { + *info = -5; + } else if (*ldqout < f2cmax(1,*nbr)) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("DLAED9_BR", &i__1, (ftnlen)9); + return; + } + + if (*k == 0) { + return; + } + +/* Root-only final merge: no parent boundary rows will be observed by */ +/* a higher merge level, so updated W and secular vectors are not */ +/* needed. */ + + if (*nbr == 0) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dlaed4_(k, &j, &dlambda[1], &w[1], &delta[1], rho, &d__[j], info); + if (*info != 0) { + goto L170; + } +/* L5: */ + } + goto L170; + } + +/* For K = 1 or 2, DLAED4/DLAED5 returns normalized eigenvectors */ +/* directly in DELTA. Keep this path identical to DLAED9's */ +/* special-case copy to S. */ + + if (*k == 1 || *k == 2) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dlaed4_(k, &j, &dlambda[1], &w[1], &delta[1], rho, &d__[j], info); + if (*info != 0) { + goto L170; + } + if (*nbr == 2) { + acc1 = 0.; + acc2 = 0.; + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + acc1 += qin[i__ * qin_dim1 + 1] * delta[i__]; + acc2 += qin[i__ * qin_dim1 + 2] * delta[i__]; +/* L10: */ + } + qout[j * qout_dim1 + 1] = acc1; + qout[j * qout_dim1 + 2] = acc2; + } else { + i__2 = *nbr; + for (r__ = 1; r__ <= i__2; ++r__) { + rowsum = 0.; + i__3 = *k; + for (i__ = 1; i__ <= i__3; ++i__) { + rowsum += qin[r__ + i__ * qin_dim1] * delta[i__]; +/* L15: */ + } + qout[r__ + j * qout_dim1] = rowsum; +/* L20: */ + } + } +/* L30: */ + } + goto L170; + } + +/* Preserve the update vector, solve all secular roots, then */ +/* accumulate the product needed to reconstruct DLAED9's updated */ +/* W. The high-relative-accuracy DELTA values produced by */ +/* DLAED4_BR are consumed immediately rather than reconstructed */ +/* later from the compact origin/tau representation. */ + + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + wsgn[i__] = w[i__]; +/* L40: */ + } + + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + wprod[i__] = 1.; +/* L41: */ + } + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + dlaed4_br_(k, &j, &dlambda[1], &wsgn[1], &delta[1], rho, &d__[j], & + iorg, &tau[j], &near__[(j << 1) + 1], &near__[(j << 1) + 2], + info); + if (*info != 0) { + goto L170; + } + + wprod[j] *= delta[j]; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + wprod[i__] *= delta[i__] / (dlambda[i__] - dlambda[j]); +/* L42: */ + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + wprod[i__] *= delta[i__] / (dlambda[i__] - dlambda[j]); +/* L43: */ + } +/* L44: */ + } + + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + d__1 = sqrt(-wprod[i__]); + w[i__] = d_sign(&d__1, &wsgn[i__]); +/* L80: */ + } + +/* Stream each secular eigenvector column through the selected rows. */ +/* Reconstruct the DELTA column from the compact origin/tau state, */ +/* using cached pole-adjacent values where cancellation is largest. */ + + if (*nbr == 2) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + if (j == *k) { + iorg = *k; + n1 = *k - 1; + n2 = *k; + } else if (tau[j] >= 0.) { + iorg = j; + n1 = j; + n2 = j + 1; + } else { + iorg = j + 1; + n1 = j; + n2 = j + 1; + } + temp = 0.; + acc1 = 0.; + acc2 = 0.; + + i__2 = n1 - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + dlt = w[i__] / (dlambda[i__] - dlambda[iorg] - tau[j]); + temp += dlt * dlt; + acc1 += qin[i__ * qin_dim1 + 1] * dlt; + acc2 += qin[i__ * qin_dim1 + 2] * dlt; +/* L85: */ + } + + dlt = w[n1] / near__[(j << 1) + 1]; + temp += dlt * dlt; + acc1 += qin[n1 * qin_dim1 + 1] * dlt; + acc2 += qin[n1 * qin_dim1 + 2] * dlt; + + i__2 = n2 - 1; + for (i__ = n1 + 1; i__ <= i__2; ++i__) { + dlt = w[i__] / (dlambda[i__] - dlambda[iorg] - tau[j]); + temp += dlt * dlt; + acc1 += qin[i__ * qin_dim1 + 1] * dlt; + acc2 += qin[i__ * qin_dim1 + 2] * dlt; +/* L86: */ + } + + dlt = w[n2] / near__[(j << 1) + 2]; + temp += dlt * dlt; + acc1 += qin[n2 * qin_dim1 + 1] * dlt; + acc2 += qin[n2 * qin_dim1 + 2] * dlt; + + i__2 = *k; + for (i__ = n2 + 1; i__ <= i__2; ++i__) { + dlt = w[i__] / (dlambda[i__] - dlambda[iorg] - tau[j]); + temp += dlt * dlt; + acc1 += qin[i__ * qin_dim1 + 1] * dlt; + acc2 += qin[i__ * qin_dim1 + 2] * dlt; +/* L87: */ + } + + temp = sqrt(temp); + qout[j * qout_dim1 + 1] = acc1 / temp; + qout[j * qout_dim1 + 2] = acc2 / temp; +/* L115: */ + } + goto L170; + } + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + if (j == *k) { + iorg = *k; + } else if (tau[j] >= 0.) { + iorg = j; + } else { + iorg = j + 1; + } + temp = 0.; + i__2 = *nbr; + for (r__ = 1; r__ <= i__2; ++r__) { + qout[r__ + j * qout_dim1] = 0.; +/* L90: */ + } + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + dlt = dlambda[i__] - dlambda[iorg] - tau[j]; + if (j == *k) { + if (i__ == *k - 1) { + dlt = near__[(j << 1) + 1]; + } + if (i__ == *k) { + dlt = near__[(j << 1) + 2]; + } + } else { + if (i__ == j) { + dlt = near__[(j << 1) + 1]; + } + if (i__ == j + 1) { + dlt = near__[(j << 1) + 2]; + } + } + dlt = w[i__] / dlt; + temp += dlt * dlt; + i__3 = *nbr; + for (r__ = 1; r__ <= i__3; ++r__) { + qout[r__ + j * qout_dim1] += qin[r__ + i__ * qin_dim1] * dlt; +/* L95: */ + } +/* L100: */ + } + temp = sqrt(temp); + i__2 = *nbr; + for (r__ = 1; r__ <= i__2; ++r__) { + qout[r__ + j * qout_dim1] /= temp; +/* L120: */ + } +/* L130: */ + } + +L170: + return; + +/* End of DLAED9_BR */ + +} /* dlaed9_br__ */ + diff --git a/lapack-netlib/SRC/dlaed9_br.f b/lapack-netlib/SRC/dlaed9_br.f new file mode 100644 index 0000000000..f513fd9735 --- /dev/null +++ b/lapack-netlib/SRC/dlaed9_br.f @@ -0,0 +1,270 @@ +*> \brief \b DLAED9_BR used by DSTEBR. +* +* DLAED9_BR finds the roots of the secular equation for one +* boundary-row DC merge and directly updates a small set of selected +* rows. It mirrors DLAED9's root solve and eigenvector normalization, +* but avoids materializing the full K-by-K secular eigenvector block. +* DLAED4_BR returns high-relative-accuracy DELTA values for each root; +* consume those DELTA values immediately to form WPROD, following the +* same numerical idea as LAPACK's SVD divide-and-conquer helpers. +* +* Serial Reference-LAPACK form: no OpenMP or thread-private +* accumulators. +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup stebr +* +*> \par Contributors: +* ================== +*> +*> Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science +*> and Technology of China +* + SUBROUTINE DLAED9_BR( K, NBR, D, QIN, LDQIN, QOUT, LDQOUT, + $ RHO, DLAMBDA, W, DELTA, WPROD, WSGN, + $ TAU, NEAR, INFO ) +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDQIN, LDQOUT, NBR + DOUBLE PRECISION RHO +* .. +* .. Array Arguments .. + DOUBLE PRECISION D( * ), DELTA( * ), DLAMBDA( * ), + $ NEAR( 2, * ), QIN( LDQIN, * ), + $ QOUT( LDQOUT, * ), TAU( * ), W( * ), + $ WPROD( * ), WSGN( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + INTEGER I, IORG, J, N1, N2, R + DOUBLE PRECISION ACC1, ACC2, DLT, ROWSUM, TEMP +* .. +* .. External Subroutines .. + EXTERNAL DLAED4, DLAED4_BR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SIGN, SQRT +* .. +* .. Executable Statements .. +* + INFO = 0 + IF( K.LT.0 ) THEN + INFO = -1 + ELSE IF( NBR.LT.0 ) THEN + INFO = -2 + ELSE IF( LDQIN.LT.MAX( 1, NBR ) ) THEN + INFO = -5 + ELSE IF( LDQOUT.LT.MAX( 1, NBR ) ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DLAED9_BR', -INFO ) + RETURN + END IF +* + IF( K.EQ.0 ) + $ RETURN +* +* Root-only final merge: no parent boundary rows will be observed by +* a higher merge level, so updated W and secular vectors are not +* needed. +* + IF( NBR.EQ.0 ) THEN + DO 5 J = 1, K + CALL DLAED4( K, J, DLAMBDA, W, DELTA, RHO, D( J ), INFO ) + IF( INFO.NE.0 ) + $ GO TO 170 + 5 CONTINUE + GO TO 170 + END IF +* +* For K = 1 or 2, DLAED4/DLAED5 returns normalized eigenvectors +* directly in DELTA. Keep this path identical to DLAED9's +* special-case copy to S. +* + IF( K.EQ.1 .OR. K.EQ.2 ) THEN + DO 30 J = 1, K + CALL DLAED4( K, J, DLAMBDA, W, DELTA, RHO, D( J ), + $ INFO ) + IF( INFO.NE.0 ) + $ GO TO 170 + IF( NBR.EQ.2 ) THEN + ACC1 = ZERO + ACC2 = ZERO + DO 10 I = 1, K + ACC1 = ACC1 + QIN( 1, I )*DELTA( I ) + ACC2 = ACC2 + QIN( 2, I )*DELTA( I ) + 10 CONTINUE + QOUT( 1, J ) = ACC1 + QOUT( 2, J ) = ACC2 + ELSE + DO 20 R = 1, NBR + ROWSUM = ZERO + DO 15 I = 1, K + ROWSUM = ROWSUM + QIN( R, I )*DELTA( I ) + 15 CONTINUE + QOUT( R, J ) = ROWSUM + 20 CONTINUE + END IF + 30 CONTINUE + GO TO 170 + END IF +* +* Preserve the update vector, solve all secular roots, then +* accumulate the product needed to reconstruct DLAED9's updated +* W. The high-relative-accuracy DELTA values produced by +* DLAED4_BR are consumed immediately rather than reconstructed +* later from the compact origin/tau representation. +* + DO 40 I = 1, K + WSGN( I ) = W( I ) + 40 CONTINUE +* + DO 41 I = 1, K + WPROD( I ) = ONE + 41 CONTINUE +* + DO 44 J = 1, K + CALL DLAED4_BR( K, J, DLAMBDA, WSGN, DELTA, RHO, D( J ), + $ IORG, TAU( J ), NEAR( 1, J ), + $ NEAR( 2, J ), INFO ) + IF( INFO.NE.0 ) + $ GO TO 170 +* + WPROD( J ) = WPROD( J )*DELTA( J ) + DO 42 I = 1, J - 1 + WPROD( I ) = WPROD( I )* + $ ( DELTA( I ) / + $ ( DLAMBDA( I )-DLAMBDA( J ) ) ) + 42 CONTINUE + DO 43 I = J + 1, K + WPROD( I ) = WPROD( I )* + $ ( DELTA( I ) / + $ ( DLAMBDA( I )-DLAMBDA( J ) ) ) + 43 CONTINUE + 44 CONTINUE +* + DO 80 I = 1, K + W( I ) = SIGN( SQRT( -WPROD( I ) ), WSGN( I ) ) + 80 CONTINUE +* +* Stream each secular eigenvector column through the selected rows. +* Reconstruct the DELTA column from the compact origin/tau state, +* using cached pole-adjacent values where cancellation is largest. +* + IF( NBR.EQ.2 ) THEN + DO 115 J = 1, K + IF( J.EQ.K ) THEN + IORG = K + N1 = K - 1 + N2 = K + ELSE IF( TAU( J ).GE.ZERO ) THEN + IORG = J + N1 = J + N2 = J + 1 + ELSE + IORG = J + 1 + N1 = J + N2 = J + 1 + END IF + TEMP = ZERO + ACC1 = ZERO + ACC2 = ZERO +* + DO 85 I = 1, N1 - 1 + DLT = W( I ) / + $ ( ( DLAMBDA( I )-DLAMBDA( IORG ) ) - TAU( J ) ) + TEMP = TEMP + DLT*DLT + ACC1 = ACC1 + QIN( 1, I )*DLT + ACC2 = ACC2 + QIN( 2, I )*DLT + 85 CONTINUE +* + DLT = W( N1 ) / NEAR( 1, J ) + TEMP = TEMP + DLT*DLT + ACC1 = ACC1 + QIN( 1, N1 )*DLT + ACC2 = ACC2 + QIN( 2, N1 )*DLT +* + DO 86 I = N1 + 1, N2 - 1 + DLT = W( I ) / + $ ( ( DLAMBDA( I )-DLAMBDA( IORG ) ) - TAU( J ) ) + TEMP = TEMP + DLT*DLT + ACC1 = ACC1 + QIN( 1, I )*DLT + ACC2 = ACC2 + QIN( 2, I )*DLT + 86 CONTINUE +* + DLT = W( N2 ) / NEAR( 2, J ) + TEMP = TEMP + DLT*DLT + ACC1 = ACC1 + QIN( 1, N2 )*DLT + ACC2 = ACC2 + QIN( 2, N2 )*DLT +* + DO 87 I = N2 + 1, K + DLT = W( I ) / + $ ( ( DLAMBDA( I )-DLAMBDA( IORG ) ) - TAU( J ) ) + TEMP = TEMP + DLT*DLT + ACC1 = ACC1 + QIN( 1, I )*DLT + ACC2 = ACC2 + QIN( 2, I )*DLT + 87 CONTINUE +* + TEMP = SQRT( TEMP ) + QOUT( 1, J ) = ACC1 / TEMP + QOUT( 2, J ) = ACC2 / TEMP + 115 CONTINUE + GO TO 170 + END IF +* + DO 130 J = 1, K + IF( J.EQ.K ) THEN + IORG = K + ELSE IF( TAU( J ).GE.ZERO ) THEN + IORG = J + ELSE + IORG = J + 1 + END IF + TEMP = ZERO + DO 90 R = 1, NBR + QOUT( R, J ) = ZERO + 90 CONTINUE + DO 100 I = 1, K + DLT = ( DLAMBDA( I )-DLAMBDA( IORG ) ) - TAU( J ) + IF( J.EQ.K ) THEN + IF( I.EQ.K-1 ) + $ DLT = NEAR( 1, J ) + IF( I.EQ.K ) + $ DLT = NEAR( 2, J ) + ELSE + IF( I.EQ.J ) + $ DLT = NEAR( 1, J ) + IF( I.EQ.J+1 ) + $ DLT = NEAR( 2, J ) + END IF + DLT = W( I ) / DLT + TEMP = TEMP + DLT*DLT + DO 95 R = 1, NBR + QOUT( R, J ) = QOUT( R, J ) + QIN( R, I )*DLT + 95 CONTINUE + 100 CONTINUE + TEMP = SQRT( TEMP ) + DO 120 R = 1, NBR + QOUT( R, J ) = QOUT( R, J ) / TEMP + 120 CONTINUE + 130 CONTINUE +* + 170 CONTINUE + RETURN +* +* End of DLAED9_BR +* + END diff --git a/lapack-netlib/SRC/dstebr.c b/lapack-netlib/SRC/dstebr.c new file mode 100644 index 0000000000..8ec2e88911 --- /dev/null +++ b/lapack-netlib/SRC/dstebr.c @@ -0,0 +1,531 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef blasint logical; + +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* -- translated by f2c (version 20000121). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ + + +/* Table of constant values */ + +static integer c__9 = 9; +static integer c__0 = 0; +static doublereal c_b19 = 1.; +static integer c__1 = 1; + +/* > \brief \b DSTEBR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE DSTEBR( N, D, E, WORK, LWORK, IWORK, LIWORK, INFO ) */ + +/* INTEGER INFO, LIWORK, LWORK, N */ +/* INTEGER IWORK( * ) */ +/* DOUBLE PRECISION D( * ), E( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > DSTEBR computes all eigenvalues of a symmetric tridiagonal matrix */ +/* > using a values-only divide-and-conquer method that propagates only */ +/* > the first and last boundary rows of each local eigenvector block */ +/* > (STEBR = Symmetric tridiagonal Eigenvalues, Boundary-Row DC). */ +/* > */ +/* > Unlike DSTEDC with COMPZ = 'N', DSTEBR does not store full secular */ +/* > eigenvector blocks across merge levels for later replay. It is a */ +/* > distinct routine and does not replace DSTEDC or DSTERF. */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is DOUBLE PRECISION array, dimension (N) */ +/* > On entry, the n diagonal elements of the tridiagonal matrix. */ +/* > On exit, if INFO = 0, the eigenvalues in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is DOUBLE PRECISION array, dimension (N-1) */ +/* > On entry, the (n-1) subdiagonal elements of the tridiagonal */ +/* > matrix. */ +/* > On exit, E has been destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > If N <= SMLSIZ, where SMLSIZ is returned by ILAENV and is */ +/* > typically about 25, LWORK must be at least 1. */ +/* > If N > SMLSIZ, LWORK must be at least */ +/* > MAX( 16*N, 2*N + SMLSIZ**2 + 2*SMLSIZ - 2 ). */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the optimal sizes of the WORK and */ +/* > IWORK arrays, returns these values as the first entries of */ +/* > the WORK and IWORK arrays, and no error message related to */ +/* > LWORK or LIWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (MAX(1,LIWORK)) */ +/* > On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LIWORK */ +/* > \verbatim */ +/* > LIWORK is INTEGER */ +/* > The dimension of the array IWORK. */ +/* > If N <= SMLSIZ, LIWORK must be at least 1. */ +/* > If N > SMLSIZ, LIWORK must be at least 7*N. */ +/* > */ +/* > If LIWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the optimal sizes of the WORK and */ +/* > IWORK arrays, returns these values as the first entries of */ +/* > the WORK and IWORK arrays, and no error message related to */ +/* > LWORK or LIWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: The algorithm failed to compute an eigenvalue while */ +/* > working on a submatrix lying in rows and columns */ +/* > INFO/(N+1) through MOD(INFO,N+1). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \ingroup stebr */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science */ +/* > and Technology of China */ + +/* ===================================================================== */ +/* Subroutine */ void dstebr_(integer *n, doublereal *d__, doublereal *e, + doublereal *work, integer *lwork, integer *iwork, integer *liwork, + integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + doublereal d__1, d__2; + + /* Local variables */ + extern /* Subroutine */ void dlaed0_br_(integer *, doublereal *, + doublereal *, doublereal *, integer *, integer *); + integer m; + doublereal eps, tiny; + integer lwmin, start; + extern doublereal dlamch_(char *); + extern /* Subroutine */ void dlascl_(char *, integer *, integer *, + doublereal *, doublereal *, integer *, integer *, doublereal *, + integer *, integer *), xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer finish; + extern doublereal dlanst_(char *, integer *, doublereal *, doublereal *); + extern /* Subroutine */ void dsterf_(integer *, doublereal *, doublereal *, + integer *), dlasrt_(char *, integer *, doublereal *, integer *); + integer liwmin; + doublereal orgnrm; + logical lquery; + integer smlsiz; + + +/* -- LAPACK computational routine -- */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --iwork; + --work; + --e; + --d__; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1 || *liwork == -1; + + if (*n < 0) { + *info = -1; + } + + if (*info == 0) { + smlsiz = ilaenv_(&c__9, "DSTEBR", " ", &c__0, &c__0, &c__0, &c__0, ( + ftnlen)6, (ftnlen)1); + if (*n <= smlsiz) { + lwmin = 1; + liwmin = 1; + } else { + +/* BLO/BHI: 2*N; merge scratch: 14*N (see DLAED7_BR). */ +/* Leaf solves need 2*N + SMLSIZ**2 + 2*SMLSIZ - 2: the */ +/* SMLSIZ-by-SMLSIZ leaf eigenvector block plus the */ +/* DSTEQR work array. */ + +/* Computing MAX */ + i__1 = *n << 4, i__2 = (*n << 1) + smlsiz * smlsiz + (smlsiz << 1) + - 2; + lwmin = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = 1, i__2 = *n * 7; + liwmin = f2cmax(i__1,i__2); + } + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -5; + } else if (*liwork < liwmin && ! lquery) { + *info = -7; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("DSTEBR", &i__1, (ftnlen)6); + return; + } else if (lquery) { + return; + } + + if (*n == 0) { + return; + } + if (*n == 1) { + return; + } + + if (*n <= smlsiz) { + dsterf_(n, &d__[1], &e[1], info); + goto L50; + } + + orgnrm = dlanst_("M", n, &d__[1], &e[1]); + if (orgnrm <= 0.) { + goto L50; + } + + eps = dlamch_("Epsilon"); + start = 1; + +L10: + if (start <= *n) { + finish = start; +L20: + if (finish < *n) { + tiny = eps * sqrt((d__1 = d__[finish], abs(d__1))) * sqrt((d__2 = + d__[finish + 1], abs(d__2))); + if ((d__1 = e[finish], abs(d__1)) > tiny) { + ++finish; + goto L20; + } + } + + m = finish - start + 1; + if (m == 1) { + start = finish + 1; + goto L10; + } + + if (m > smlsiz) { + orgnrm = dlanst_("M", &m, &d__[start], &e[start]); + dlascl_("G", &c__0, &c__0, &orgnrm, &c_b19, &m, &c__1, &d__[start] + , &m, info); + i__1 = m - 1; + i__2 = m - 1; + dlascl_("G", &c__0, &c__0, &orgnrm, &c_b19, &i__1, &c__1, &e[ + start], &i__2, info); + + dlaed0_br_(&m, &d__[start], &e[start], &work[1], &iwork[1], info) + ; + if (*info != 0) { + *info = (*info / (m + 1) + start - 1) * (*n + 1) + *info % (m + + 1) + start - 1; + goto L50; + } + + dlascl_("G", &c__0, &c__0, &c_b19, &orgnrm, &m, &c__1, &d__[start] + , &m, info); + } else { + dsterf_(&m, &d__[start], &e[start], info); + if (*info != 0) { + *info = start * (*n + 1) + finish; + goto L50; + } + } + + start = finish + 1; + goto L10; + } + + dlasrt_("I", n, &d__[1], info); + +L50: + work[1] = (doublereal) lwmin; + iwork[1] = liwmin; + return; + +/* End of DSTEBR */ + +} /* dstebr_ */ + diff --git a/lapack-netlib/SRC/dstebr.f b/lapack-netlib/SRC/dstebr.f new file mode 100644 index 0000000000..d2a44edea9 --- /dev/null +++ b/lapack-netlib/SRC/dstebr.f @@ -0,0 +1,280 @@ +*> \brief \b DSTEBR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE DSTEBR( N, D, E, WORK, LWORK, IWORK, LIWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LIWORK, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* DOUBLE PRECISION D( * ), E( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> DSTEBR computes all eigenvalues of a symmetric tridiagonal matrix +*> using a values-only divide-and-conquer method that propagates only +*> the first and last boundary rows of each local eigenvector block +*> (STEBR = Symmetric tridiagonal Eigenvalues, Boundary-Row DC). +*> +*> Unlike DSTEDC with COMPZ = 'N', DSTEBR does not store full secular +*> eigenvector blocks across merge levels for later replay. It is a +*> distinct routine and does not replace DSTEDC or DSTERF. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix. N >= 0. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> On entry, the n diagonal elements of the tridiagonal matrix. +*> On exit, if INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is DOUBLE PRECISION array, dimension (N-1) +*> On entry, the (n-1) subdiagonal elements of the tridiagonal +*> matrix. +*> On exit, E has been destroyed. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If N <= SMLSIZ, where SMLSIZ is returned by ILAENV and is +*> typically about 25, LWORK must be at least 1. +*> If N > SMLSIZ, LWORK must be at least +*> MAX( 16*N, 2*N + SMLSIZ**2 + 2*SMLSIZ - 2 ). +*> +*> If LWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK and IWORK arrays, and no error message related to +*> LWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. +*> If N <= SMLSIZ, LIWORK must be at least 1. +*> If N > SMLSIZ, LIWORK must be at least 7*N. +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK and IWORK arrays, and no error message related to +*> LWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: The algorithm failed to compute an eigenvalue while +*> working on a submatrix lying in rows and columns +*> INFO/(N+1) through MOD(INFO,N+1). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup stebr +* +*> \par Contributors: +* ================== +*> +*> Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science +*> and Technology of China +* +* ===================================================================== + SUBROUTINE DSTEBR( N, D, E, WORK, LWORK, IWORK, LIWORK, INFO ) +* +* -- LAPACK computational routine -- +* +* .. Scalar Arguments .. + INTEGER INFO, LIWORK, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + DOUBLE PRECISION D( * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + DOUBLE PRECISION ZERO, ONE + PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER FINISH, LIWMIN, LWMIN, M, SMLSIZ, START + DOUBLE PRECISION EPS, ORGNRM, TINY +* .. +* .. External Functions .. + INTEGER ILAENV + DOUBLE PRECISION DLAMCH, DLANST + EXTERNAL ILAENV, DLAMCH, DLANST +* .. +* .. External Subroutines .. + EXTERNAL DLAED0_BR, DLASCL, DLASRT, DSTERF, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MOD, SQRT +* .. +* .. Executable Statements .. +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) +* + IF( N.LT.0 ) THEN + INFO = -1 + END IF +* + IF( INFO.EQ.0 ) THEN + SMLSIZ = ILAENV( 9, 'DSTEBR', ' ', 0, 0, 0, 0 ) + IF( N.LE.SMLSIZ ) THEN + LWMIN = 1 + LIWMIN = 1 + ELSE +* +* BLO/BHI: 2*N; merge scratch: 14*N (see DLAED7_BR). +* Leaf solves need 2*N + SMLSIZ**2 + 2*SMLSIZ - 2: the +* SMLSIZ-by-SMLSIZ leaf eigenvector block plus the +* DSTEQR work array. +* + LWMIN = MAX( 16*N, 2*N + SMLSIZ*SMLSIZ + 2*SMLSIZ - 2 ) + LIWMIN = MAX( 1, 7*N ) + END IF + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -5 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'DSTEBR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* + IF( N.EQ.0 ) + $ RETURN + IF( N.EQ.1 ) + $ RETURN +* + IF( N.LE.SMLSIZ ) THEN + CALL DSTERF( N, D, E, INFO ) + GO TO 50 + END IF +* + ORGNRM = DLANST( 'M', N, D, E ) + IF( ORGNRM.LE.ZERO ) + $ GO TO 50 +* + EPS = DLAMCH( 'Epsilon' ) + START = 1 +* + 10 CONTINUE + IF( START.LE.N ) THEN + FINISH = START + 20 CONTINUE + IF( FINISH.LT.N ) THEN + TINY = EPS*SQRT( ABS( D( FINISH ) ) )* + $ SQRT( ABS( D( FINISH+1 ) ) ) + IF( ABS( E( FINISH ) ).GT.TINY ) THEN + FINISH = FINISH + 1 + GO TO 20 + END IF + END IF +* + M = FINISH - START + 1 + IF( M.EQ.1 ) THEN + START = FINISH + 1 + GO TO 10 + END IF +* + IF( M.GT.SMLSIZ ) THEN + ORGNRM = DLANST( 'M', M, D( START ), E( START ) ) + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), + $ M, INFO ) + CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, + $ E( START ), M-1, INFO ) +* + CALL DLAED0_BR( M, D( START ), E( START ), WORK, IWORK, + $ INFO ) + IF( INFO.NE.0 ) THEN + INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) + + $ MOD( INFO, ( M+1 ) ) + START - 1 + GO TO 50 + END IF +* + CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), + $ M, INFO ) + ELSE + CALL DSTERF( M, D( START ), E( START ), INFO ) + IF( INFO.NE.0 ) THEN + INFO = START*( N+1 ) + FINISH + GO TO 50 + END IF + END IF +* + START = FINISH + 1 + GO TO 10 + END IF +* + CALL DLASRT( 'I', N, D, INFO ) +* + 50 CONTINUE + WORK( 1 ) = LWMIN + IWORK( 1 ) = LIWMIN + RETURN +* +* End of DSTEBR +* + END diff --git a/lapack-netlib/SRC/dsteqr_boundary_br.c b/lapack-netlib/SRC/dsteqr_boundary_br.c new file mode 100644 index 0000000000..6b8cc24861 --- /dev/null +++ b/lapack-netlib/SRC/dsteqr_boundary_br.c @@ -0,0 +1,283 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef blasint logical; + +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* -- translated by f2c (version 20000121). + You must link the resulting object file with the libraries: + -lf2c -lm (in that order) +*/ + + +/* > \brief \b DSTEQR_BOUNDARY_BR solves one leaf and keeps boundary rows. */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \ingroup stebr */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science */ +/* > and Technology of China */ + +/* Subroutine */ void dsteqr_boundary_br_(integer *n, doublereal *d__, + doublereal *e, doublereal *blo, doublereal *bhi, doublereal *q, + integer *ldq, doublereal *work, integer *info) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer j; + extern /* Subroutine */ void dsteqr_(char *, integer *, doublereal *, + doublereal *, doublereal *, integer *, doublereal *, integer *); + + + + /* Parameter adjustments */ + --work; + --q; + --bhi; + --blo; + --e; + --d__; + + /* Function Body */ + dsteqr_("I", n, &d__[1], &e[1], &q[1], ldq, &work[1], info); + if (*info != 0) { + return; + } + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + blo[j] = q[(j - 1) * *ldq + 1]; + bhi[j] = q[*n + (j - 1) * *ldq]; +/* L10: */ + } + return; +} /* dsteqr_boundary_br__ */ + diff --git a/lapack-netlib/SRC/dsteqr_boundary_br.f b/lapack-netlib/SRC/dsteqr_boundary_br.f new file mode 100644 index 0000000000..72e8d0950b --- /dev/null +++ b/lapack-netlib/SRC/dsteqr_boundary_br.f @@ -0,0 +1,36 @@ +*> \brief \b DSTEQR_BOUNDARY_BR solves one leaf and keeps boundary rows. +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup stebr +* +*> \par Contributors: +* ================== +*> +*> Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science +*> and Technology of China +* + SUBROUTINE DSTEQR_BOUNDARY_BR( N, D, E, BLO, BHI, Q, LDQ, WORK, + $ INFO ) +* + INTEGER INFO, J, LDQ, N + DOUBLE PRECISION BLO( * ), BHI( * ), D( * ), E( * ), Q( * ), + $ WORK( * ) + EXTERNAL DSTEQR +* + CALL DSTEQR( 'I', N, D, E, Q, LDQ, WORK, INFO ) + IF( INFO.NE.0 ) + $ RETURN +* + DO 10 J = 1, N + BLO( J ) = Q( 1 + ( J - 1 )*LDQ ) + BHI( J ) = Q( N + ( J - 1 )*LDQ ) + 10 CONTINUE + RETURN + END diff --git a/lapack-netlib/SRC/slaed0_br.c b/lapack-netlib/SRC/slaed0_br.c new file mode 100644 index 0000000000..96467f4e09 --- /dev/null +++ b/lapack-netlib/SRC/slaed0_br.c @@ -0,0 +1,439 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef blasint logical; + +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* Table of constant values */ + +static integer c__9 = 9; +static integer c__0 = 0; +static integer c__14 = 14; +static integer c__1 = 1; + +/* > \brief \b SLAED0_BR used by SSTEBR. */ + +/* SLAED0_BR computes eigenvalues of a symmetric tridiagonal matrix with */ +/* the boundary-row divide-and-conquer method used by SSTEBR. Unlike */ +/* SLAED0(ICOMPQ=0), it keeps only first/last boundary rows for each */ +/* active block across merge levels instead of saving complete */ +/* eigenvector blocks. */ + +/* Serial Reference-LAPACK form: no OpenMP, environment-variable */ +/* scheduling, or thread-scaled workspace. */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \ingroup stebr */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science */ +/* > and Technology of China */ + +/* Subroutine */ void slaed0_br_(integer *n, real *d__, real *e, real *work, + integer *iwork, integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + real r__1; + + /* Local variables */ + integer i__, j, k; + extern /* Subroutine */ void slaed0_merge_pair_(integer *, integer *, + integer *, logical *, real *, real *, real *, integer *, integer * + , integer *, integer *, integer *, integer *, integer *, integer * + , integer *, integer *, integer *, integer *, integer *), + ssteqr_boundary_br_(integer *, real *, real *, real *, real *, + real *, integer *, real *, integer *); + integer msd2, smm1, spm1, ibhi, iblo, iscr, kdefl, qbase, merge, wbase, + infom, indxq, iiwrk; + logical wantq; + extern /* Subroutine */ void scopy_(integer *, real *, integer *, real *, + integer *); + integer iwbase, nmerge; + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer submat, subpbs, matsiz, smlsiz, wrkbase; + + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --iwork; + --work; + --e; + --d__; + + /* Function Body */ + *info = 0; + if (*n < 0) { + *info = -1; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLAED0_BR", &i__1, (ftnlen)9); + return; + } + + if (*n == 0) { + return; + } + + smlsiz = ilaenv_(&c__9, "SLAED0", " ", &c__0, &c__0, &c__0, &c__0, ( + ftnlen)6, (ftnlen)1); + +/* Determine the size and placement of leaf submatrices. */ + + iwork[1] = *n; + subpbs = 1; +L10: + if (iwork[subpbs] > smlsiz) { + for (j = subpbs; j >= 1; --j) { + iwork[j * 2] = (iwork[j] + 1) / 2; + iwork[(j << 1) - 1] = iwork[j] / 2; +/* L20: */ + } + subpbs <<= 1; + goto L10; + } + i__1 = subpbs; + for (j = 2; j <= i__1; ++j) { + iwork[j] += iwork[j - 1]; +/* L30: */ + } + +/* Apply rank-1 cuts. */ + + spm1 = subpbs - 1; + i__1 = spm1; + for (i__ = 1; i__ <= i__1; ++i__) { + submat = iwork[i__] + 1; + smm1 = submat - 1; + d__[smm1] -= (r__1 = e[smm1], abs(r__1)); + d__[submat] -= (r__1 = e[smm1], abs(r__1)); +/* L40: */ + } + +/* Workspace layout: */ +/* WORK(IBLO:IBLO+N-1) first boundary rows */ +/* WORK(IBHI:IBHI+N-1) last boundary rows */ +/* WORK(ISCR:) leaf scratch and per-merge scratch */ + +/* Integer workspace layout: */ +/* IWORK(1:N) split endpoints */ +/* IWORK(INDXQ:INDXQ+N-1) sorting permutations */ +/* IWORK(IIWRK:) SLAED7_BR scratch */ + + iblo = 1; + ibhi = iblo + *n; + iscr = ibhi + *n; + indxq = *n + 1; + iiwrk = indxq + *n; + +/* Solve leaf eigenproblems and initialize boundary row invariants. */ + + i__1 = subpbs; + for (i__ = 1; i__ <= i__1; ++i__) { + qbase = iscr; + wbase = qbase + smlsiz * smlsiz; + if (i__ == 1) { + submat = 1; + matsiz = iwork[1]; + } else { + submat = iwork[i__ - 1] + 1; + matsiz = iwork[i__] - iwork[i__ - 1]; + } + + ssteqr_boundary_br_(&matsiz, &d__[submat], &e[submat], &work[iblo + + submat - 1], &work[ibhi + submat - 1], &work[qbase], &smlsiz, + &work[wbase], info); + if (*info != 0) { + goto L130; + } + k = 1; + i__2 = iwork[i__]; + for (j = submat; j <= i__2; ++j) { + iwork[indxq + j - 1] = k; + ++k; +/* L65: */ + } +/* L70: */ + } + +/* Merge adjacent eigensystems. Boundary rows are updated in place */ +/* for the merged physical D order. */ + +L80: + if (subpbs > 1) { + wantq = subpbs > 2; + nmerge = subpbs / 2; + i__1 = nmerge; + for (merge = 1; merge <= i__1; ++merge) { + slaed0_merge_pair_(&merge, &nmerge, &iwork[1], &wantq, &d__[1], & + e[1], &work[1], &iblo, &ibhi, &iscr, &iiwrk, &indxq, & + submat, &matsiz, &msd2, &wrkbase, &iwbase, &kdefl, &infom, + &c__14); + if (infom != 0) { + *info = infom; + goto L130; + } +/* L90: */ + } + + i__1 = nmerge; + for (merge = 1; merge <= i__1; ++merge) { + iwork[merge] = iwork[merge * 2]; +/* L95: */ + } + subpbs /= 2; + goto L80; + } + +/* Reorder eigenvalues from the final physical merge order. */ + + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + j = iwork[indxq + i__ - 1]; + work[iscr + i__ - 1] = d__[j]; +/* L100: */ + } + scopy_(n, &work[iscr], &c__1, &d__[1], &c__1); + goto L140; + +L130: + *info = submat * (*n + 1) + submat + matsiz - 1; + +L140: + return; + +/* End of SLAED0_BR */ + +} /* slaed0_br__ */ + diff --git a/lapack-netlib/SRC/slaed0_br.f b/lapack-netlib/SRC/slaed0_br.f new file mode 100644 index 0000000000..784445a0d5 --- /dev/null +++ b/lapack-netlib/SRC/slaed0_br.f @@ -0,0 +1,189 @@ +*> \brief \b SLAED0_BR used by SSTEBR. +* +* SLAED0_BR computes eigenvalues of a symmetric tridiagonal matrix with +* the boundary-row divide-and-conquer method used by SSTEBR. Unlike +* SLAED0(ICOMPQ=0), it keeps only first/last boundary rows for each +* active block across merge levels instead of saving complete +* eigenvector blocks. +* +* Serial Reference-LAPACK form: no OpenMP, environment-variable +* scheduling, or thread-scaled workspace. +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup stebr +* +*> \par Contributors: +* ================== +*> +*> Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science +*> and Technology of China +* + SUBROUTINE SLAED0_BR( N, D, E, WORK, IWORK, INFO ) +* +* .. Scalar Arguments .. + INTEGER INFO, N +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + REAL D( * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + INTEGER WRKSTR + PARAMETER ( WRKSTR = 14 ) +* .. +* .. Local Scalars .. + LOGICAL WANTQ + INTEGER I, IBHI, IBLO, IIWRK, INDXQ, INFOM, ISCR, + $ IWBASE, J, K, KDEFL, MATSIZ, MERGE, MSD2, + $ NMERGE, QBASE, SMLSIZ, SMM1, SPM1, SUBMAT, + $ SUBPBS, WBASE, WRKBASE +* .. +* .. External Subroutines .. + EXTERNAL SCOPY, SLAED0_MERGE_PAIR, + $ SSTEQR_BOUNDARY_BR, XERBLA +* .. +* .. External Functions .. + INTEGER ILAENV + EXTERNAL ILAENV +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. +* + INFO = 0 + IF( N.LT.0 ) THEN + INFO = -1 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SLAED0_BR', -INFO ) + RETURN + END IF +* + IF( N.EQ.0 ) + $ RETURN +* + SMLSIZ = ILAENV( 9, 'SLAED0', ' ', 0, 0, 0, 0 ) +* +* Determine the size and placement of leaf submatrices. +* + IWORK( 1 ) = N + SUBPBS = 1 + 10 CONTINUE + IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN + DO 20 J = SUBPBS, 1, -1 + IWORK( 2*J ) = ( IWORK( J )+1 ) / 2 + IWORK( 2*J-1 ) = IWORK( J ) / 2 + 20 CONTINUE + SUBPBS = 2*SUBPBS + GO TO 10 + END IF + DO 30 J = 2, SUBPBS + IWORK( J ) = IWORK( J ) + IWORK( J-1 ) + 30 CONTINUE +* +* Apply rank-1 cuts. +* + SPM1 = SUBPBS - 1 + DO 40 I = 1, SPM1 + SUBMAT = IWORK( I ) + 1 + SMM1 = SUBMAT - 1 + D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) ) + D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) ) + 40 CONTINUE +* +* Workspace layout: +* WORK(IBLO:IBLO+N-1) first boundary rows +* WORK(IBHI:IBHI+N-1) last boundary rows +* WORK(ISCR:) leaf scratch and per-merge scratch +* +* Integer workspace layout: +* IWORK(1:N) split endpoints +* IWORK(INDXQ:INDXQ+N-1) sorting permutations +* IWORK(IIWRK:) SLAED7_BR scratch +* + IBLO = 1 + IBHI = IBLO + N + ISCR = IBHI + N + INDXQ = N + 1 + IIWRK = INDXQ + N +* +* Solve leaf eigenproblems and initialize boundary row invariants. +* + DO 70 I = 1, SUBPBS + QBASE = ISCR + WBASE = QBASE + SMLSIZ*SMLSIZ + IF( I.EQ.1 ) THEN + SUBMAT = 1 + MATSIZ = IWORK( 1 ) + ELSE + SUBMAT = IWORK( I-1 ) + 1 + MATSIZ = IWORK( I ) - IWORK( I-1 ) + END IF +* + CALL SSTEQR_BOUNDARY_BR( MATSIZ, D( SUBMAT ), E( SUBMAT ), + $ WORK( IBLO+SUBMAT-1 ), + $ WORK( IBHI+SUBMAT-1 ), + $ WORK( QBASE ), SMLSIZ, WORK( WBASE ), + $ INFO ) + IF( INFO.NE.0 ) + $ GO TO 130 + K = 1 + DO 65 J = SUBMAT, IWORK( I ) + IWORK( INDXQ+J-1 ) = K + K = K + 1 + 65 CONTINUE + 70 CONTINUE +* +* Merge adjacent eigensystems. Boundary rows are updated in place +* for the merged physical D order. +* + 80 CONTINUE + IF( SUBPBS.GT.1 ) THEN + WANTQ = SUBPBS.GT.2 + NMERGE = SUBPBS / 2 + DO 90 MERGE = 1, NMERGE + CALL SLAED0_MERGE_PAIR( MERGE, NMERGE, IWORK, WANTQ, D, E, + $ WORK, IBLO, IBHI, ISCR, IIWRK, INDXQ, SUBMAT, MATSIZ, + $ MSD2, WRKBASE, IWBASE, KDEFL, INFOM, WRKSTR ) + IF( INFOM.NE.0 ) THEN + INFO = INFOM + GO TO 130 + END IF + 90 CONTINUE +* + DO 95 MERGE = 1, NMERGE + IWORK( MERGE ) = IWORK( 2*MERGE ) + 95 CONTINUE + SUBPBS = SUBPBS / 2 + GO TO 80 + END IF +* +* Reorder eigenvalues from the final physical merge order. +* + DO 100 I = 1, N + J = IWORK( INDXQ+I-1 ) + WORK( ISCR+I-1 ) = D( J ) + 100 CONTINUE + CALL SCOPY( N, WORK( ISCR ), 1, D, 1 ) + GO TO 140 +* + 130 CONTINUE + INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1 +* + 140 CONTINUE + RETURN +* +* End of SLAED0_BR +* + END diff --git a/lapack-netlib/SRC/slaed0_merge_pair.c b/lapack-netlib/SRC/slaed0_merge_pair.c new file mode 100644 index 0000000000..5b124e86f0 --- /dev/null +++ b/lapack-netlib/SRC/slaed0_merge_pair.c @@ -0,0 +1,284 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef blasint logical; + +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* > \brief \b SLAED0_MERGE_PAIR executes one merge in the DC tree. */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \ingroup stebr */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science */ +/* > and Technology of China */ + +/* Subroutine */ void slaed0_merge_pair_(integer *merge, integer *nmerge, + integer *iwork, logical *wantq, real *d__, real *e, real *work, + integer *iblo, integer *ibhi, integer *iscr, integer *iiwrk, integer * + indxq, integer *submat, integer *matsiz, integer *msd2, integer * + wrkbase, integer *iwbase, integer *kdefl, integer *info, integer * + wrkstr) +{ + extern /* Subroutine */ void slaed7_br_(logical *, integer *, integer *, + real *, integer *, real *, real *, real *, real *, integer *, + integer *, integer *); + integer left, right; + + + + + /* Parameter adjustments */ + --work; + --e; + --d__; + --iwork; + + /* Function Body */ + left = (*merge << 1) - 1; + right = left + 1; + if (*merge == 1) { + *submat = 1; + *matsiz = iwork[right]; + *msd2 = iwork[1]; + } else { + *submat = iwork[left - 1] + 1; + *matsiz = iwork[right] - iwork[left - 1]; + *msd2 = iwork[left] - iwork[left - 1]; + } + + *wrkbase = *iscr + *wrkstr * (*submat - 1); + *iwbase = *iiwrk + (*submat - 1) * 5; + + slaed7_br_(wantq, matsiz, msd2, &d__[*submat], &iwork[*indxq + *submat - + 1], &e[*submat + *msd2 - 1], &work[*iblo + *submat - 1], &work[* + ibhi + *submat - 1], &work[*wrkbase], &iwork[*iwbase], kdefl, + info); + return; +} /* slaed0_merge_pair__ */ + diff --git a/lapack-netlib/SRC/slaed0_merge_pair.f b/lapack-netlib/SRC/slaed0_merge_pair.f new file mode 100644 index 0000000000..ecaeb48c88 --- /dev/null +++ b/lapack-netlib/SRC/slaed0_merge_pair.f @@ -0,0 +1,55 @@ +*> \brief \b SLAED0_MERGE_PAIR executes one merge in the DC tree. +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup stebr +* +*> \par Contributors: +* ================== +*> +*> Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science +*> and Technology of China +* + SUBROUTINE SLAED0_MERGE_PAIR( MERGE, NMERGE, IWORK, WANTQ, D, E, + $ WORK, IBLO, IBHI, ISCR, IIWRK, + $ INDXQ, SUBMAT, MATSIZ, MSD2, + $ WRKBASE, IWBASE, KDEFL, INFO, + $ WRKSTR ) +* + INTEGER IBHI, IBLO, IIWRK, INDXQ, INFO, ISCR, IWBASE, + $ KDEFL, MATSIZ, MERGE, MSD2, NMERGE, RIGHT, + $ SUBMAT, WRKBASE, WRKSTR + LOGICAL WANTQ + INTEGER IWORK( * ) + REAL D( * ), E( * ), WORK( * ) + EXTERNAL SLAED7_BR +* + INTEGER LEFT +* + LEFT = 2*MERGE - 1 + RIGHT = LEFT + 1 + IF( MERGE.EQ.1 ) THEN + SUBMAT = 1 + MATSIZ = IWORK( RIGHT ) + MSD2 = IWORK( 1 ) + ELSE + SUBMAT = IWORK( LEFT-1 ) + 1 + MATSIZ = IWORK( RIGHT ) - IWORK( LEFT-1 ) + MSD2 = IWORK( LEFT ) - IWORK( LEFT-1 ) + END IF +* + WRKBASE = ISCR + WRKSTR*( SUBMAT-1 ) + IWBASE = IIWRK + 5*( SUBMAT-1 ) +* + CALL SLAED7_BR( WANTQ, MATSIZ, MSD2, D( SUBMAT ), + $ IWORK( INDXQ+SUBMAT-1 ), E( SUBMAT+MSD2-1 ), + $ WORK( IBLO+SUBMAT-1 ), WORK( IBHI+SUBMAT-1 ), + $ WORK( WRKBASE ), IWORK( IWBASE ), KDEFL, INFO ) + RETURN + END diff --git a/lapack-netlib/SRC/slaed4_br.c b/lapack-netlib/SRC/slaed4_br.c new file mode 100644 index 0000000000..47e8e56a61 --- /dev/null +++ b/lapack-netlib/SRC/slaed4_br.c @@ -0,0 +1,345 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef blasint logical; + +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* > \brief \b SLAED4_BR used by SSTEBR. */ + +/* SLAED4_BR computes one secular root with SLAED4 and exposes a compact */ +/* representation of the returned high-relative-accuracy DELTA vector. */ +/* For N > 2, SLAED4's DELTA entries are all relative to either D(I) */ +/* or D(I+1), except for the final root where the origin is D(N). */ +/* ORG records that origin index and TAU satisfies */ + +/* lambda = D(ORG) + TAU, */ +/* DELTA(j) = D(j) - D(ORG) - TAU. */ + +/* NEAR1/NEAR2 cache the two pole-adjacent DELTA entries that are most */ +/* sensitive to cancellation when reconstructed from D and TAU. */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \ingroup stebr */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science */ +/* > and Technology of China */ + +/* Subroutine */ void slaed4_br_(integer *n, integer *i__, real *d__, real * + z__, real *delta, real *rho, real *dlam, integer *org, real *tau, + real *near1, real *near2, integer *info) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + real mid; + extern /* Subroutine */ void slaed4_(integer *, integer *, real *, real *, + real *, real *, real *, integer *), xerbla_(char *, integer *, ftnlen); + + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --delta; + --z__; + --d__; + + /* Function Body */ + *info = 0; + *org = 1; + *tau = 0.f; + *near1 = 0.f; + *near2 = 0.f; + + if (*n < 1) { + *info = -1; + } else if (*i__ < 1 || *i__ > *n) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLAED4_BR", &i__1, (ftnlen)9); + return; + } + + slaed4_(n, i__, &d__[1], &z__[1], &delta[1], rho, dlam, info); + if (*info != 0) { + return; + } + + if (*n == 1) { + *org = 1; + *tau = *dlam - d__[1]; + *near1 = delta[1]; + *near2 = 0.f; + return; + } + + if (*n == 2) { + *org = 1; + *tau = *dlam - d__[1]; + *near1 = delta[1]; + *near2 = delta[2]; + return; + } + + if (*i__ == *n) { + *org = *n; + } else { + mid = (d__[*i__] + d__[*i__ + 1]) * .5f; + if (*dlam < mid) { + *org = *i__; + } else { + *org = *i__ + 1; + } + } + +/* Avoid reconstructing TAU from DLAM-D(ORG). SLAED4 already */ +/* returned DELTA(ORG) in its shifted coordinate, so using */ +/* TAU=-DELTA(ORG) preserves that final rounded denominator and */ +/* avoids an extra add/subtract rounding through DLAM. */ + + *tau = -delta[*org]; + + if (*i__ == *n) { + *near1 = delta[*n - 1]; + *near2 = delta[*n]; + } else { + *near1 = delta[*i__]; + *near2 = delta[*i__ + 1]; + } + + return; + +/* End of SLAED4_BR */ + +} /* slaed4_br__ */ + diff --git a/lapack-netlib/SRC/slaed4_br.f b/lapack-netlib/SRC/slaed4_br.f new file mode 100644 index 0000000000..ea4c9d3ea5 --- /dev/null +++ b/lapack-netlib/SRC/slaed4_br.f @@ -0,0 +1,125 @@ +*> \brief \b SLAED4_BR used by SSTEBR. +* +* SLAED4_BR computes one secular root with SLAED4 and exposes a compact +* representation of the returned high-relative-accuracy DELTA vector. +* For N > 2, SLAED4's DELTA entries are all relative to either D(I) +* or D(I+1), except for the final root where the origin is D(N). +* ORG records that origin index and TAU satisfies +* +* lambda = D(ORG) + TAU, +* DELTA(j) = D(j) - D(ORG) - TAU. +* +* NEAR1/NEAR2 cache the two pole-adjacent DELTA entries that are most +* sensitive to cancellation when reconstructed from D and TAU. +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup stebr +* +*> \par Contributors: +* ================== +*> +*> Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science +*> and Technology of China +* + SUBROUTINE SLAED4_BR( N, I, D, Z, DELTA, RHO, DLAM, ORG, + $ TAU, NEAR1, NEAR2, INFO ) +* +* .. Scalar Arguments .. + INTEGER I, INFO, N, ORG + REAL DLAM, NEAR1, NEAR2, RHO, TAU +* .. +* .. Array Arguments .. + REAL D( * ), DELTA( * ), Z( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL HALF, ZERO + PARAMETER ( HALF = 0.5E0, ZERO = 0.0E0 ) +* .. +* .. Local Scalars .. + REAL MID +* .. +* .. External Subroutines .. + EXTERNAL SLAED4, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS +* .. +* .. Executable Statements .. +* + INFO = 0 + ORG = 1 + TAU = ZERO + NEAR1 = ZERO + NEAR2 = ZERO +* + IF( N.LT.1 ) THEN + INFO = -1 + ELSE IF( I.LT.1 .OR. I.GT.N ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SLAED4_BR', -INFO ) + RETURN + END IF +* + CALL SLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO ) + IF( INFO.NE.0 ) + $ RETURN +* + IF( N.EQ.1 ) THEN + ORG = 1 + TAU = DLAM - D( 1 ) + NEAR1 = DELTA( 1 ) + NEAR2 = ZERO + RETURN + END IF +* + IF( N.EQ.2 ) THEN + ORG = 1 + TAU = DLAM - D( 1 ) + NEAR1 = DELTA( 1 ) + NEAR2 = DELTA( 2 ) + RETURN + END IF +* + IF( I.EQ.N ) THEN + ORG = N + ELSE + MID = HALF*( D( I )+D( I+1 ) ) + IF( DLAM.LT.MID ) THEN + ORG = I + ELSE + ORG = I + 1 + END IF + END IF +* +* Avoid reconstructing TAU from DLAM-D(ORG). SLAED4 already +* returned DELTA(ORG) in its shifted coordinate, so using +* TAU=-DELTA(ORG) preserves that final rounded denominator and +* avoids an extra add/subtract rounding through DLAM. +* + TAU = -DELTA( ORG ) +* + IF( I.EQ.N ) THEN + NEAR1 = DELTA( N-1 ) + NEAR2 = DELTA( N ) + ELSE + NEAR1 = DELTA( I ) + NEAR2 = DELTA( I+1 ) + END IF +* + RETURN +* +* End of SLAED4_BR +* + END diff --git a/lapack-netlib/SRC/slaed7_br.c b/lapack-netlib/SRC/slaed7_br.c new file mode 100644 index 0000000000..7a316251e1 --- /dev/null +++ b/lapack-netlib/SRC/slaed7_br.c @@ -0,0 +1,423 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef blasint logical; + +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* Table of constant values */ + +static integer c__2 = 2; +static integer c__1 = 1; +static integer c_n1 = -1; + +/* > \brief \b SLAED7_BR used by SSTEBR. */ + +/* SLAED7_BR performs one divide-and-conquer merge while propagating */ +/* only the first and last rows of the current local eigenvector block. */ +/* It is called by SLAED0_BR and is not itself a public LAPACK API. */ + +/* Serial Reference-LAPACK form: no OpenMP or thread-scaled workspace. */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \ingroup stebr */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science */ +/* > and Technology of China */ + +/* Subroutine */ void slaed7_br_(logical *wantq, integer *n, integer *cutpnt, + real *d__, integer *indxq, real *rho, real *blo, real *bhi, real * + work, integer *iwork, integer *kdefl, integer *info) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + extern /* Subroutine */ void slaed8_br_(integer *, integer *, integer *, + real *, real *, integer *, integer *, real *, integer *, real *, + real *, real *, integer *, real *, integer *, integer *, integer * + , real *, integer *, integer *, integer *), slaed9_br_(integer *, + integer *, real *, real *, integer *, real *, integer *, real *, + real *, real *, real *, real *, real *, real *, real *, integer *) + ; + integer i__, j, k, n1, n2, iq, iw, iz, iq2, nbr, iscr, itau, inear, iindx, + iperm, iwsgn, idlmda, igivcl; + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen), slamrg_( + integer *, integer *, real *, integer *, integer *, integer *); + integer igivnm, iindxp, givptr; + + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --iwork; + --work; + --bhi; + --blo; + --indxq; + --d__; + + /* Function Body */ + *info = 0; + *kdefl = 0; + if (*n < 0) { + *info = -1; + } else if (*cutpnt < f2cmin(1,*n) || *cutpnt > *n) { + *info = -2; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLAED7_BR", &i__1, (ftnlen)9); + return; + } + + if (*n == 0) { + return; + } + +/* Workspace layout (14*N doubles): */ + +/* Z, DLAMBDA, W : N each */ +/* QBR, Q2BR, GIVNUM/reused WPROD : 2*N each */ +/* DELTA, WSGN, TAU, NEAR : N, N, N, 2*N */ + + iz = 1; + idlmda = iz + *n; + iw = idlmda + *n; + iq = iw + *n; + iq2 = iq + (*n << 1); + igivnm = iq2 + (*n << 1); + iscr = igivnm + (*n << 1); + iwsgn = iscr + *n; + itau = iwsgn + *n; + inear = itau + *n; + +/* Integer workspace layout. */ + + iindxp = 1; + iindx = iindxp + *n; + iperm = iindx + *n; + igivcl = iperm + *n; + + if (*wantq) { + nbr = 2; + } else { + nbr = 0; + } + +/* Z is the rank-one update vector. QBR has two selected rows of */ +/* blockdiag(Q_left,Q_right): parent first boundary and parent last */ +/* boundary, represented in the child eigenbases. The root merge has */ +/* no parent, so it only needs Z for the secular eigenvalues. */ + + if (*wantq) { + i__1 = *cutpnt; + for (j = 1; j <= i__1; ++j) { + work[iz + j - 1] = bhi[j]; + work[iq + (j - 1 << 1)] = blo[j]; + work[iq + (j - 1 << 1) + 1] = 0.f; +/* L20: */ + } + i__1 = *n; + for (j = *cutpnt + 1; j <= i__1; ++j) { + work[iz + j - 1] = blo[j]; + work[iq + (j - 1 << 1)] = 0.f; + work[iq + (j - 1 << 1) + 1] = bhi[j]; +/* L30: */ + } + } else { + i__1 = *cutpnt; + for (j = 1; j <= i__1; ++j) { + work[iz + j - 1] = bhi[j]; +/* L40: */ + } + i__1 = *n; + for (j = *cutpnt + 1; j <= i__1; ++j) { + work[iz + j - 1] = blo[j]; +/* L50: */ + } + } + +/* Sort and deflate, applying the same Givens/permutation actions to */ +/* the selected boundary rows when a parent merge will need them. */ + + + slaed8_br_(&nbr, &k, n, &d__[1], &work[iq], &c__2, &indxq[1], rho, + cutpnt, &work[iz], &work[idlmda], &work[iq2], &c__2, &work[iw], & + iwork[iperm], &givptr, &iwork[igivcl], &work[igivnm], &iwork[ + iindxp], &iwork[iindx], info); + if (*info != 0) { + goto L70; + } + *kdefl = k; + +/* Solve the secular equation and directly update the selected rows. */ +/* WORK(ISCR) holds one SLAED4 delta vector at a time; no K-by-K */ +/* delta or eigenvector block is materialized. */ + + if (k != 0) { + slaed9_br_(&k, &nbr, &d__[1], &work[iq2], &c__2, &work[iq], &c__2, + rho, &work[idlmda], &work[iw], &work[iscr], &work[igivnm], & + work[iwsgn], &work[itau], &work[inear], info); + if (*info != 0) { + goto L70; + } + +/* Prepare INDXQ sorting permutation. */ + + n1 = k; + n2 = *n - k; + slamrg_(&n1, &n2, &d__[1], &c__1, &c_n1, &indxq[1]); + } else { + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + indxq[i__] = i__; +/* L60: */ + } + } + +/* Persist the parent boundary rows in the current physical D order. */ + + if (*wantq) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + blo[j] = work[iq + (j - 1 << 1)]; + bhi[j] = work[iq + (j - 1 << 1) + 1]; +/* L65: */ + } + } + +L70: + return; + +/* End of SLAED7_BR */ + +} /* slaed7_br__ */ + diff --git a/lapack-netlib/SRC/slaed7_br.f b/lapack-netlib/SRC/slaed7_br.f new file mode 100644 index 0000000000..316312a768 --- /dev/null +++ b/lapack-netlib/SRC/slaed7_br.f @@ -0,0 +1,178 @@ +*> \brief \b SLAED7_BR used by SSTEBR. +* +* SLAED7_BR performs one divide-and-conquer merge while propagating +* only the first and last rows of the current local eigenvector block. +* It is called by SLAED0_BR and is not itself a public LAPACK API. +* +* Serial Reference-LAPACK form: no OpenMP or thread-scaled workspace. +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup stebr +* +*> \par Contributors: +* ================== +*> +*> Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science +*> and Technology of China +* + SUBROUTINE SLAED7_BR( WANTQ, N, CUTPNT, D, INDXQ, RHO, BLO, BHI, + $ WORK, IWORK, KDEFL, INFO ) +* +* .. Scalar Arguments .. + LOGICAL WANTQ + INTEGER CUTPNT, INFO, KDEFL, N + REAL RHO +* .. +* .. Array Arguments .. + INTEGER INDXQ( * ), IWORK( * ) + REAL BLO( * ), BHI( * ), D( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO + PARAMETER ( ZERO = 0.0E0 ) +* .. +* .. Local Scalars .. + INTEGER GIVPTR, IDLMDA, IGIVCL, IGIVNM, I, IINDX, + $ IINDXP, INEAR, IPERM, IQ, IQ2, ISCR, ITAU, IW, + $ IWSGN, IZ, J, K, N1, N2, NBR +* .. +* .. External Subroutines .. + EXTERNAL SLAED8_BR, SLAED9_BR, SLAMRG, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC MAX, MIN +* .. +* .. Executable Statements .. +* + INFO = 0 + KDEFL = 0 + IF( N.LT.0 ) THEN + INFO = -1 + ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN + INFO = -2 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SLAED7_BR', -INFO ) + RETURN + END IF +* + IF( N.EQ.0 ) + $ RETURN +* +* Workspace layout (14*N doubles): +* +* Z, DLAMBDA, W : N each +* QBR, Q2BR, GIVNUM/reused WPROD : 2*N each +* DELTA, WSGN, TAU, NEAR : N, N, N, 2*N +* + IZ = 1 + IDLMDA = IZ + N + IW = IDLMDA + N + IQ = IW + N + IQ2 = IQ + 2*N + IGIVNM = IQ2 + 2*N + ISCR = IGIVNM + 2*N + IWSGN = ISCR + N + ITAU = IWSGN + N + INEAR = ITAU + N +* +* Integer workspace layout. +* + IINDXP = 1 + IINDX = IINDXP + N + IPERM = IINDX + N + IGIVCL = IPERM + N +* + IF( WANTQ ) THEN + NBR = 2 + ELSE + NBR = 0 + END IF +* +* Z is the rank-one update vector. QBR has two selected rows of +* blockdiag(Q_left,Q_right): parent first boundary and parent last +* boundary, represented in the child eigenbases. The root merge has +* no parent, so it only needs Z for the secular eigenvalues. +* + IF( WANTQ ) THEN + DO 20 J = 1, CUTPNT + WORK( IZ+J-1 ) = BHI( J ) + WORK( IQ+2*( J-1 ) ) = BLO( J ) + WORK( IQ+2*( J-1 )+1 ) = ZERO + 20 CONTINUE + DO 30 J = CUTPNT + 1, N + WORK( IZ+J-1 ) = BLO( J ) + WORK( IQ+2*( J-1 ) ) = ZERO + WORK( IQ+2*( J-1 )+1 ) = BHI( J ) + 30 CONTINUE + ELSE + DO 40 J = 1, CUTPNT + WORK( IZ+J-1 ) = BHI( J ) + 40 CONTINUE + DO 50 J = CUTPNT + 1, N + WORK( IZ+J-1 ) = BLO( J ) + 50 CONTINUE + END IF +* +* Sort and deflate, applying the same Givens/permutation actions to +* the selected boundary rows when a parent merge will need them. +* +* + CALL SLAED8_BR( NBR, K, N, D, WORK( IQ ), 2, INDXQ, RHO, + $ CUTPNT, WORK( IZ ), WORK( IDLMDA ), + $ WORK( IQ2 ), 2, WORK( IW ), IWORK( IPERM ), + $ GIVPTR, IWORK( IGIVCL ), WORK( IGIVNM ), + $ IWORK( IINDXP ), IWORK( IINDX ), INFO ) + IF( INFO.NE.0 ) + $ GO TO 70 + KDEFL = K +* +* Solve the secular equation and directly update the selected rows. +* WORK(ISCR) holds one SLAED4 delta vector at a time; no K-by-K +* delta or eigenvector block is materialized. +* + IF( K.NE.0 ) THEN + CALL SLAED9_BR( K, NBR, D, WORK( IQ2 ), 2, WORK( IQ ), 2, + $ RHO, WORK( IDLMDA ), WORK( IW ), + $ WORK( ISCR ), WORK( IGIVNM ), + $ WORK( IWSGN ), WORK( ITAU ), + $ WORK( INEAR ), INFO ) + IF( INFO.NE.0 ) + $ GO TO 70 +* +* Prepare INDXQ sorting permutation. +* + N1 = K + N2 = N - K + CALL SLAMRG( N1, N2, D, 1, -1, INDXQ ) + ELSE + DO 60 I = 1, N + INDXQ( I ) = I + 60 CONTINUE + END IF +* +* Persist the parent boundary rows in the current physical D order. +* + IF( WANTQ ) THEN + DO 65 J = 1, N + BLO( J ) = WORK( IQ+2*( J-1 ) ) + BHI( J ) = WORK( IQ+2*( J-1 )+1 ) + 65 CONTINUE + END IF +* + 70 CONTINUE + RETURN +* +* End of SLAED7_BR +* + END diff --git a/lapack-netlib/SRC/slaed8_br.c b/lapack-netlib/SRC/slaed8_br.c new file mode 100644 index 0000000000..e46ec16afb --- /dev/null +++ b/lapack-netlib/SRC/slaed8_br.c @@ -0,0 +1,496 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef blasint logical; + +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* Table of constant values */ + +static real c_b3 = -1.f; +static integer c__1 = 1; + +/* > \brief \b SLAED8_BR selected-row variant of SLAED8. */ + +/* SLAED8_BR mirrors SLAED8 deflation and bookkeeping but applies the */ +/* column rotations/permutations to NBR selected rows rather than to a */ +/* full eigenvector matrix. It is an internal helper for SLAED7_BR. */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \ingroup stebr */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science */ +/* > and Technology of China */ + +/* Subroutine */ void slaed8_br_(integer *nbr, integer *k, integer *n, real * + d__, real *q, integer *ldq, integer *indxq, real *rho, integer * + cutpnt, real *z__, real *dlambda, real *q2, integer *ldq2, real *w, + integer *perm, integer *givptr, integer *givcol, real *givnum, + integer *indxp, integer *indx, integer *info) +{ + /* System generated locals */ + integer q_dim1, q_offset, q2_dim1, q2_offset, i__1; + real r__1; + + /* Local variables */ + real c__; + integer i__, j; + real s, t; + integer k2, n1, n2, jp, n1p1; + real eps, tau, tol; + integer jlam, imax, jmax; + extern /* Subroutine */ void srot_(integer *, real *, integer *, real *, + integer *, real *, real *), sscal_(integer *, real *, real *, + integer *), scopy_(integer *, real *, integer *, real *, integer * + ); + extern real slapy2_(real *, real *), slamch_(char *); + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); + extern integer isamax_(integer *, real *, integer *); + extern /* Subroutine */ void slamrg_(integer *, integer *, real *, integer + *, integer *, integer *), slacpy_(char *, integer *, integer *, + real *, integer *, real *, integer *); + + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --d__; + q_dim1 = *ldq; + q_offset = 1 + q_dim1; + q -= q_offset; + --indxq; + --z__; + --dlambda; + q2_dim1 = *ldq2; + q2_offset = 1 + q2_dim1; + q2 -= q2_offset; + --w; + --perm; + givcol -= 3; + givnum -= 3; + --indxp; + --indx; + + /* Function Body */ + *info = 0; + if (*nbr < 0) { + *info = -1; + } else if (*n < 0) { + *info = -3; + } else if (*ldq < f2cmax(1,*nbr)) { + *info = -6; + } else if (*cutpnt < f2cmin(1,*n) || *cutpnt > *n) { + *info = -9; + } else if (*ldq2 < f2cmax(1,*nbr)) { + *info = -13; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLAED8_BR", &i__1, (ftnlen)9); + return; + } + + *givptr = 0; + if (*n == 0) { + return; + } + + n1 = *cutpnt; + n2 = *n - n1; + n1p1 = n1 + 1; + + if (*rho < 0.f) { + sscal_(&n2, &c_b3, &z__[n1p1], &c__1); + } + + t = 1.f / sqrt(2.f); + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + indx[j] = j; +/* L80: */ + } + sscal_(n, &t, &z__[1], &c__1); + *rho = (r__1 = *rho * 2.f, abs(r__1)); + +/* Sort the eigenvalues into increasing order. */ + + i__1 = *n; + for (i__ = *cutpnt + 1; i__ <= i__1; ++i__) { + indxq[i__] += *cutpnt; +/* L90: */ + } + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + dlambda[i__] = d__[indxq[i__]]; + w[i__] = z__[indxq[i__]]; +/* L100: */ + } + slamrg_(&n1, &n2, &dlambda[1], &c__1, &c__1, &indx[1]); + i__1 = *n; + for (i__ = 1; i__ <= i__1; ++i__) { + d__[i__] = dlambda[indx[i__]]; + z__[i__] = w[indx[i__]]; +/* L110: */ + } + + imax = isamax_(n, &z__[1], &c__1); + jmax = isamax_(n, &d__[1], &c__1); + eps = slamch_("Epsilon"); + tol = eps * 8.f * (r__1 = d__[jmax], abs(r__1)); + + if (*rho * (r__1 = z__[imax], abs(r__1)) <= tol) { + *k = 0; + if (*nbr == 0) { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + perm[j] = indxq[indx[j]]; +/* L115: */ + } + } else { + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + perm[j] = indxq[indx[j]]; + scopy_(nbr, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + + 1], &c__1); +/* L120: */ + } + slacpy_("A", nbr, n, &q2[q2_offset], ldq2, &q[q_offset], ldq); + } + return; + } + + *k = 0; + k2 = *n + 1; + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + if (*rho * (r__1 = z__[j], abs(r__1)) <= tol) { + --k2; + indxp[k2] = j; + if (j == *n) { + goto L170; + } + } else { + jlam = j; + goto L140; + } +/* L130: */ + } +L140: + ++j; + if (j > *n) { + goto L160; + } + if (*rho * (r__1 = z__[j], abs(r__1)) <= tol) { + --k2; + indxp[k2] = j; + } else { + s = z__[jlam]; + c__ = z__[j]; + tau = slapy2_(&c__, &s); + t = d__[j] - d__[jlam]; + c__ /= tau; + s = -s / tau; + if ((r__1 = t * c__ * s, abs(r__1)) <= tol) { + z__[j] = tau; + z__[jlam] = 0.f; + + ++(*givptr); + givcol[(*givptr << 1) + 1] = indxq[indx[jlam]]; + givcol[(*givptr << 1) + 2] = indxq[indx[j]]; + givnum[(*givptr << 1) + 1] = c__; + givnum[(*givptr << 1) + 2] = s; + if (*nbr != 0) { + srot_(nbr, &q[indxq[indx[jlam]] * q_dim1 + 1], &c__1, &q[ + indxq[indx[j]] * q_dim1 + 1], &c__1, &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; + i__ = 1; +L150: + if (k2 + i__ <= *n) { + if (d__[jlam] < d__[indxp[k2 + i__]]) { + indxp[k2 + i__ - 1] = indxp[k2 + i__]; + indxp[k2 + i__] = jlam; + ++i__; + goto L150; + } else { + indxp[k2 + i__ - 1] = jlam; + } + } else { + indxp[k2 + i__ - 1] = jlam; + } + jlam = j; + } else { + ++(*k); + w[*k] = z__[jlam]; + dlambda[*k] = d__[jlam]; + indxp[*k] = jlam; + jlam = j; + } + } + goto L140; +L160: + + ++(*k); + w[*k] = z__[jlam]; + dlambda[*k] = d__[jlam]; + indxp[*k] = jlam; + +L170: + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + jp = indxp[j]; + dlambda[j] = d__[jp]; + perm[j] = indxq[indx[jp]]; + if (*nbr != 0) { + scopy_(nbr, &q[perm[j] * q_dim1 + 1], &c__1, &q2[j * q2_dim1 + 1], + &c__1); + } +/* L180: */ + } + + if (*k < *n) { + i__1 = *n - *k; + scopy_(&i__1, &dlambda[*k + 1], &c__1, &d__[*k + 1], &c__1); + if (*nbr != 0) { + i__1 = *n - *k; + slacpy_("A", nbr, &i__1, &q2[(*k + 1) * q2_dim1 + 1], ldq2, &q[(* + k + 1) * q_dim1 + 1], ldq); + } + } + + return; + +/* End of SLAED8_BR */ + +} /* slaed8_br__ */ + diff --git a/lapack-netlib/SRC/slaed8_br.f b/lapack-netlib/SRC/slaed8_br.f new file mode 100644 index 0000000000..c0e6acb68c --- /dev/null +++ b/lapack-netlib/SRC/slaed8_br.f @@ -0,0 +1,229 @@ +*> \brief \b SLAED8_BR selected-row variant of SLAED8. +* +* SLAED8_BR mirrors SLAED8 deflation and bookkeeping but applies the +* column rotations/permutations to NBR selected rows rather than to a +* full eigenvector matrix. It is an internal helper for SLAED7_BR. +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup stebr +* +*> \par Contributors: +* ================== +*> +*> Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science +*> and Technology of China +* + SUBROUTINE SLAED8_BR( NBR, K, N, D, Q, LDQ, INDXQ, RHO, + $ CUTPNT, Z, DLAMBDA, Q2, LDQ2, W, PERM, + $ GIVPTR, GIVCOL, GIVNUM, INDXP, INDX, + $ INFO ) +* +* .. Scalar Arguments .. + INTEGER CUTPNT, GIVPTR, INFO, K, LDQ, LDQ2, N, NBR + REAL RHO +* .. +* .. Array Arguments .. + INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ), + $ INDXQ( * ), PERM( * ) + REAL D( * ), DLAMBDA( * ), GIVNUM( 2, * ), + $ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL MONE, ZERO, ONE, TWO, EIGHT + PARAMETER ( MONE = -1.0E0, ZERO = 0.0E0, + $ ONE = 1.0E0, TWO = 2.0E0, EIGHT = 8.0E0 ) +* .. +* .. Local Scalars .. + INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2 + REAL C, EPS, S, T, TAU, TOL +* .. +* .. External Functions .. + INTEGER ISAMAX + REAL SLAMCH, SLAPY2 + EXTERNAL ISAMAX, SLAMCH, SLAPY2 +* .. +* .. External Subroutines .. + EXTERNAL SCOPY, SLACPY, SLAMRG, SROT, SSCAL, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MIN, SQRT +* .. +* .. Executable Statements .. +* + INFO = 0 + IF( NBR.LT.0 ) THEN + INFO = -1 + ELSE IF( N.LT.0 ) THEN + INFO = -3 + ELSE IF( LDQ.LT.MAX( 1, NBR ) ) THEN + INFO = -6 + ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN + INFO = -9 + ELSE IF( LDQ2.LT.MAX( 1, NBR ) ) THEN + INFO = -13 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SLAED8_BR', -INFO ) + RETURN + END IF +* + GIVPTR = 0 + IF( N.EQ.0 ) + $ RETURN +* + N1 = CUTPNT + N2 = N - N1 + N1P1 = N1 + 1 +* + IF( RHO.LT.ZERO ) THEN + CALL SSCAL( N2, MONE, Z( N1P1 ), 1 ) + END IF +* + T = ONE / SQRT( TWO ) + DO 80 J = 1, N + INDX( J ) = J + 80 CONTINUE + CALL SSCAL( N, T, Z, 1 ) + RHO = ABS( TWO*RHO ) +* +* Sort the eigenvalues into increasing order. +* + DO 90 I = CUTPNT + 1, N + INDXQ( I ) = INDXQ( I ) + CUTPNT + 90 CONTINUE + DO 100 I = 1, N + DLAMBDA( I ) = D( INDXQ( I ) ) + W( I ) = Z( INDXQ( I ) ) + 100 CONTINUE + CALL SLAMRG( N1, N2, DLAMBDA, 1, 1, INDX ) + DO 110 I = 1, N + D( I ) = DLAMBDA( INDX( I ) ) + Z( I ) = W( INDX( I ) ) + 110 CONTINUE +* + IMAX = ISAMAX( N, Z, 1 ) + JMAX = ISAMAX( N, D, 1 ) + EPS = SLAMCH( 'Epsilon' ) + TOL = EIGHT*EPS*ABS( D( JMAX ) ) +* + IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN + K = 0 + IF( NBR.EQ.0 ) THEN + DO 115 J = 1, N + PERM( J ) = INDXQ( INDX( J ) ) + 115 CONTINUE + ELSE + DO 120 J = 1, N + PERM( J ) = INDXQ( INDX( J ) ) + CALL SCOPY( NBR, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 ) + 120 CONTINUE + CALL SLACPY( 'A', NBR, N, Q2, LDQ2, Q, LDQ ) + END IF + RETURN + END IF +* + K = 0 + K2 = N + 1 + DO 130 J = 1, N + IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN + K2 = K2 - 1 + INDXP( K2 ) = J + IF( J.EQ.N ) + $ GO TO 170 + ELSE + JLAM = J + GO TO 140 + END IF + 130 CONTINUE + 140 CONTINUE + J = J + 1 + IF( J.GT.N ) + $ GO TO 160 + IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN + K2 = K2 - 1 + INDXP( K2 ) = J + ELSE + S = Z( JLAM ) + C = Z( J ) + TAU = SLAPY2( C, S ) + T = D( J ) - D( JLAM ) + C = C / TAU + S = -S / TAU + IF( ABS( T*C*S ).LE.TOL ) THEN + Z( J ) = TAU + Z( JLAM ) = ZERO +* + GIVPTR = GIVPTR + 1 + GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) ) + GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) ) + GIVNUM( 1, GIVPTR ) = C + GIVNUM( 2, GIVPTR ) = S + IF( NBR.NE.0 ) + $ CALL SROT( NBR, Q( 1, INDXQ( INDX( JLAM ) ) ), 1, + $ Q( 1, INDXQ( INDX( J ) ) ), 1, 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 + 150 CONTINUE + IF( K2+I.LE.N ) THEN + IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN + INDXP( K2+I-1 ) = INDXP( K2+I ) + INDXP( K2+I ) = JLAM + I = I + 1 + GO TO 150 + ELSE + INDXP( K2+I-1 ) = JLAM + END IF + ELSE + INDXP( K2+I-1 ) = JLAM + END IF + JLAM = J + ELSE + K = K + 1 + W( K ) = Z( JLAM ) + DLAMBDA( K ) = D( JLAM ) + INDXP( K ) = JLAM + JLAM = J + END IF + END IF + GO TO 140 + 160 CONTINUE +* + K = K + 1 + W( K ) = Z( JLAM ) + DLAMBDA( K ) = D( JLAM ) + INDXP( K ) = JLAM +* + 170 CONTINUE + DO 180 J = 1, N + JP = INDXP( J ) + DLAMBDA( J ) = D( JP ) + PERM( J ) = INDXQ( INDX( JP ) ) + IF( NBR.NE.0 ) + $ CALL SCOPY( NBR, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 ) + 180 CONTINUE +* + IF( K.LT.N ) THEN + CALL SCOPY( N-K, DLAMBDA( K+1 ), 1, D( K+1 ), 1 ) + IF( NBR.NE.0 ) + $ CALL SLACPY( 'A', NBR, N-K, Q2( 1, K+1 ), LDQ2, + $ Q( 1, K+1 ), LDQ ) + END IF +* + RETURN +* +* End of SLAED8_BR +* + END diff --git a/lapack-netlib/SRC/slaed9_br.c b/lapack-netlib/SRC/slaed9_br.c new file mode 100644 index 0000000000..09c3e17681 --- /dev/null +++ b/lapack-netlib/SRC/slaed9_br.c @@ -0,0 +1,545 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef blasint logical; + +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* > \brief \b SLAED9_BR used by SSTEBR. */ + +/* SLAED9_BR finds the roots of the secular equation for one */ +/* boundary-row DC merge and directly updates a small set of selected */ +/* rows. It mirrors SLAED9's root solve and eigenvector normalization, */ +/* but avoids materializing the full K-by-K secular eigenvector block. */ +/* SLAED4_BR returns high-relative-accuracy DELTA values for each root; */ +/* consume those DELTA values immediately to form WPROD, following the */ +/* same numerical idea as LAPACK's SVD divide-and-conquer helpers. */ + +/* Serial Reference-LAPACK form: no OpenMP or thread-private */ +/* accumulators. */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \ingroup stebr */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science */ +/* > and Technology of China */ + +/* Subroutine */ void slaed9_br_(integer *k, integer *nbr, real *d__, real * + qin, integer *ldqin, real *qout, integer *ldqout, real *rho, real * + dlambda, real *w, real *delta, real *wprod, real *wsgn, real *tau, + real *near__, integer *info) +{ + /* System generated locals */ + integer qin_dim1, qin_offset, qout_dim1, qout_offset, i__1, i__2, i__3; + real r__1; + + /* Local variables */ + extern /* Subroutine */ void slaed4_br_(integer *, integer *, real *, + real *, real *, real *, real *, integer *, real *, real *, real *, + integer *); + integer i__, j, r__, n1, n2; + real dlt, acc1, acc2; + integer iorg; + real temp; + extern /* Subroutine */ void slaed4_(integer *, integer *, real *, real *, + real *, real *, real *, integer *), xerbla_(char *, integer *, ftnlen); + real rowsum; + + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --d__; + qin_dim1 = *ldqin; + qin_offset = 1 + qin_dim1; + qin -= qin_offset; + qout_dim1 = *ldqout; + qout_offset = 1 + qout_dim1; + qout -= qout_offset; + --dlambda; + --w; + --delta; + --wprod; + --wsgn; + --tau; + near__ -= 3; + + /* Function Body */ + *info = 0; + if (*k < 0) { + *info = -1; + } else if (*nbr < 0) { + *info = -2; + } else if (*ldqin < f2cmax(1,*nbr)) { + *info = -5; + } else if (*ldqout < f2cmax(1,*nbr)) { + *info = -7; + } + if (*info != 0) { + i__1 = -(*info); + xerbla_("SLAED9_BR", &i__1, (ftnlen)9); + return; + } + + if (*k == 0) { + return; + } + +/* Root-only final merge: no parent boundary rows will be observed by */ +/* a higher merge level, so updated W and secular vectors are not */ +/* needed. */ + + if (*nbr == 0) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + slaed4_(k, &j, &dlambda[1], &w[1], &delta[1], rho, &d__[j], info); + if (*info != 0) { + goto L170; + } +/* L5: */ + } + goto L170; + } + +/* For K = 1 or 2, SLAED4/SLAED5 returns normalized eigenvectors */ +/* directly in DELTA. Keep this path identical to SLAED9's */ +/* special-case copy to S. */ + + if (*k == 1 || *k == 2) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + slaed4_(k, &j, &dlambda[1], &w[1], &delta[1], rho, &d__[j], info); + if (*info != 0) { + goto L170; + } + if (*nbr == 2) { + acc1 = 0.f; + acc2 = 0.f; + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + acc1 += qin[i__ * qin_dim1 + 1] * delta[i__]; + acc2 += qin[i__ * qin_dim1 + 2] * delta[i__]; +/* L10: */ + } + qout[j * qout_dim1 + 1] = acc1; + qout[j * qout_dim1 + 2] = acc2; + } else { + i__2 = *nbr; + for (r__ = 1; r__ <= i__2; ++r__) { + rowsum = 0.f; + i__3 = *k; + for (i__ = 1; i__ <= i__3; ++i__) { + rowsum += qin[r__ + i__ * qin_dim1] * delta[i__]; +/* L15: */ + } + qout[r__ + j * qout_dim1] = rowsum; +/* L20: */ + } + } +/* L30: */ + } + goto L170; + } + +/* Preserve the update vector, solve all secular roots, then */ +/* accumulate the product needed to reconstruct SLAED9's updated */ +/* W. The high-relative-accuracy DELTA values produced by */ +/* SLAED4_BR are consumed immediately rather than reconstructed */ +/* later from the compact origin/tau representation. */ + + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + wsgn[i__] = w[i__]; +/* L40: */ + } + + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + wprod[i__] = 1.f; +/* L41: */ + } + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + slaed4_br_(k, &j, &dlambda[1], &wsgn[1], &delta[1], rho, &d__[j], & + iorg, &tau[j], &near__[(j << 1) + 1], &near__[(j << 1) + 2], + info); + if (*info != 0) { + goto L170; + } + + wprod[j] *= delta[j]; + i__2 = j - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + wprod[i__] *= delta[i__] / (dlambda[i__] - dlambda[j]); +/* L42: */ + } + i__2 = *k; + for (i__ = j + 1; i__ <= i__2; ++i__) { + wprod[i__] *= delta[i__] / (dlambda[i__] - dlambda[j]); +/* L43: */ + } +/* L44: */ + } + + i__1 = *k; + for (i__ = 1; i__ <= i__1; ++i__) { + r__1 = sqrt(-wprod[i__]); + w[i__] = r_sign(&r__1, &wsgn[i__]); +/* L80: */ + } + +/* Stream each secular eigenvector column through the selected rows. */ +/* Reconstruct the DELTA column from the compact origin/tau state, */ +/* using cached pole-adjacent values where cancellation is largest. */ + + if (*nbr == 2) { + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + if (j == *k) { + iorg = *k; + n1 = *k - 1; + n2 = *k; + } else if (tau[j] >= 0.f) { + iorg = j; + n1 = j; + n2 = j + 1; + } else { + iorg = j + 1; + n1 = j; + n2 = j + 1; + } + temp = 0.f; + acc1 = 0.f; + acc2 = 0.f; + + i__2 = n1 - 1; + for (i__ = 1; i__ <= i__2; ++i__) { + dlt = w[i__] / (dlambda[i__] - dlambda[iorg] - tau[j]); + temp += dlt * dlt; + acc1 += qin[i__ * qin_dim1 + 1] * dlt; + acc2 += qin[i__ * qin_dim1 + 2] * dlt; +/* L85: */ + } + + dlt = w[n1] / near__[(j << 1) + 1]; + temp += dlt * dlt; + acc1 += qin[n1 * qin_dim1 + 1] * dlt; + acc2 += qin[n1 * qin_dim1 + 2] * dlt; + + i__2 = n2 - 1; + for (i__ = n1 + 1; i__ <= i__2; ++i__) { + dlt = w[i__] / (dlambda[i__] - dlambda[iorg] - tau[j]); + temp += dlt * dlt; + acc1 += qin[i__ * qin_dim1 + 1] * dlt; + acc2 += qin[i__ * qin_dim1 + 2] * dlt; +/* L86: */ + } + + dlt = w[n2] / near__[(j << 1) + 2]; + temp += dlt * dlt; + acc1 += qin[n2 * qin_dim1 + 1] * dlt; + acc2 += qin[n2 * qin_dim1 + 2] * dlt; + + i__2 = *k; + for (i__ = n2 + 1; i__ <= i__2; ++i__) { + dlt = w[i__] / (dlambda[i__] - dlambda[iorg] - tau[j]); + temp += dlt * dlt; + acc1 += qin[i__ * qin_dim1 + 1] * dlt; + acc2 += qin[i__ * qin_dim1 + 2] * dlt; +/* L87: */ + } + + temp = sqrt(temp); + qout[j * qout_dim1 + 1] = acc1 / temp; + qout[j * qout_dim1 + 2] = acc2 / temp; +/* L115: */ + } + goto L170; + } + + i__1 = *k; + for (j = 1; j <= i__1; ++j) { + if (j == *k) { + iorg = *k; + } else if (tau[j] >= 0.f) { + iorg = j; + } else { + iorg = j + 1; + } + temp = 0.f; + i__2 = *nbr; + for (r__ = 1; r__ <= i__2; ++r__) { + qout[r__ + j * qout_dim1] = 0.f; +/* L90: */ + } + i__2 = *k; + for (i__ = 1; i__ <= i__2; ++i__) { + dlt = dlambda[i__] - dlambda[iorg] - tau[j]; + if (j == *k) { + if (i__ == *k - 1) { + dlt = near__[(j << 1) + 1]; + } + if (i__ == *k) { + dlt = near__[(j << 1) + 2]; + } + } else { + if (i__ == j) { + dlt = near__[(j << 1) + 1]; + } + if (i__ == j + 1) { + dlt = near__[(j << 1) + 2]; + } + } + dlt = w[i__] / dlt; + temp += dlt * dlt; + i__3 = *nbr; + for (r__ = 1; r__ <= i__3; ++r__) { + qout[r__ + j * qout_dim1] += qin[r__ + i__ * qin_dim1] * dlt; +/* L95: */ + } +/* L100: */ + } + temp = sqrt(temp); + i__2 = *nbr; + for (r__ = 1; r__ <= i__2; ++r__) { + qout[r__ + j * qout_dim1] /= temp; +/* L120: */ + } +/* L130: */ + } + +L170: + return; + +/* End of SLAED9_BR */ + +} /* slaed9_br__ */ + diff --git a/lapack-netlib/SRC/slaed9_br.f b/lapack-netlib/SRC/slaed9_br.f new file mode 100644 index 0000000000..5254cf5af8 --- /dev/null +++ b/lapack-netlib/SRC/slaed9_br.f @@ -0,0 +1,270 @@ +*> \brief \b SLAED9_BR used by SSTEBR. +* +* SLAED9_BR finds the roots of the secular equation for one +* boundary-row DC merge and directly updates a small set of selected +* rows. It mirrors SLAED9's root solve and eigenvector normalization, +* but avoids materializing the full K-by-K secular eigenvector block. +* SLAED4_BR returns high-relative-accuracy DELTA values for each root; +* consume those DELTA values immediately to form WPROD, following the +* same numerical idea as LAPACK's SVD divide-and-conquer helpers. +* +* Serial Reference-LAPACK form: no OpenMP or thread-private +* accumulators. +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup stebr +* +*> \par Contributors: +* ================== +*> +*> Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science +*> and Technology of China +* + SUBROUTINE SLAED9_BR( K, NBR, D, QIN, LDQIN, QOUT, LDQOUT, + $ RHO, DLAMBDA, W, DELTA, WPROD, WSGN, + $ TAU, NEAR, INFO ) +* +* .. Scalar Arguments .. + INTEGER INFO, K, LDQIN, LDQOUT, NBR + REAL RHO +* .. +* .. Array Arguments .. + REAL D( * ), DELTA( * ), DLAMBDA( * ), + $ NEAR( 2, * ), QIN( LDQIN, * ), + $ QOUT( LDQOUT, * ), TAU( * ), W( * ), + $ WPROD( * ), WSGN( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) +* .. +* .. Local Scalars .. + INTEGER I, IORG, J, N1, N2, R + REAL ACC1, ACC2, DLT, ROWSUM, TEMP +* .. +* .. External Subroutines .. + EXTERNAL SLAED4, SLAED4_BR, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, SIGN, SQRT +* .. +* .. Executable Statements .. +* + INFO = 0 + IF( K.LT.0 ) THEN + INFO = -1 + ELSE IF( NBR.LT.0 ) THEN + INFO = -2 + ELSE IF( LDQIN.LT.MAX( 1, NBR ) ) THEN + INFO = -5 + ELSE IF( LDQOUT.LT.MAX( 1, NBR ) ) THEN + INFO = -7 + END IF + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SLAED9_BR', -INFO ) + RETURN + END IF +* + IF( K.EQ.0 ) + $ RETURN +* +* Root-only final merge: no parent boundary rows will be observed by +* a higher merge level, so updated W and secular vectors are not +* needed. +* + IF( NBR.EQ.0 ) THEN + DO 5 J = 1, K + CALL SLAED4( K, J, DLAMBDA, W, DELTA, RHO, D( J ), INFO ) + IF( INFO.NE.0 ) + $ GO TO 170 + 5 CONTINUE + GO TO 170 + END IF +* +* For K = 1 or 2, SLAED4/SLAED5 returns normalized eigenvectors +* directly in DELTA. Keep this path identical to SLAED9's +* special-case copy to S. +* + IF( K.EQ.1 .OR. K.EQ.2 ) THEN + DO 30 J = 1, K + CALL SLAED4( K, J, DLAMBDA, W, DELTA, RHO, D( J ), + $ INFO ) + IF( INFO.NE.0 ) + $ GO TO 170 + IF( NBR.EQ.2 ) THEN + ACC1 = ZERO + ACC2 = ZERO + DO 10 I = 1, K + ACC1 = ACC1 + QIN( 1, I )*DELTA( I ) + ACC2 = ACC2 + QIN( 2, I )*DELTA( I ) + 10 CONTINUE + QOUT( 1, J ) = ACC1 + QOUT( 2, J ) = ACC2 + ELSE + DO 20 R = 1, NBR + ROWSUM = ZERO + DO 15 I = 1, K + ROWSUM = ROWSUM + QIN( R, I )*DELTA( I ) + 15 CONTINUE + QOUT( R, J ) = ROWSUM + 20 CONTINUE + END IF + 30 CONTINUE + GO TO 170 + END IF +* +* Preserve the update vector, solve all secular roots, then +* accumulate the product needed to reconstruct SLAED9's updated +* W. The high-relative-accuracy DELTA values produced by +* SLAED4_BR are consumed immediately rather than reconstructed +* later from the compact origin/tau representation. +* + DO 40 I = 1, K + WSGN( I ) = W( I ) + 40 CONTINUE +* + DO 41 I = 1, K + WPROD( I ) = ONE + 41 CONTINUE +* + DO 44 J = 1, K + CALL SLAED4_BR( K, J, DLAMBDA, WSGN, DELTA, RHO, D( J ), + $ IORG, TAU( J ), NEAR( 1, J ), + $ NEAR( 2, J ), INFO ) + IF( INFO.NE.0 ) + $ GO TO 170 +* + WPROD( J ) = WPROD( J )*DELTA( J ) + DO 42 I = 1, J - 1 + WPROD( I ) = WPROD( I )* + $ ( DELTA( I ) / + $ ( DLAMBDA( I )-DLAMBDA( J ) ) ) + 42 CONTINUE + DO 43 I = J + 1, K + WPROD( I ) = WPROD( I )* + $ ( DELTA( I ) / + $ ( DLAMBDA( I )-DLAMBDA( J ) ) ) + 43 CONTINUE + 44 CONTINUE +* + DO 80 I = 1, K + W( I ) = SIGN( SQRT( -WPROD( I ) ), WSGN( I ) ) + 80 CONTINUE +* +* Stream each secular eigenvector column through the selected rows. +* Reconstruct the DELTA column from the compact origin/tau state, +* using cached pole-adjacent values where cancellation is largest. +* + IF( NBR.EQ.2 ) THEN + DO 115 J = 1, K + IF( J.EQ.K ) THEN + IORG = K + N1 = K - 1 + N2 = K + ELSE IF( TAU( J ).GE.ZERO ) THEN + IORG = J + N1 = J + N2 = J + 1 + ELSE + IORG = J + 1 + N1 = J + N2 = J + 1 + END IF + TEMP = ZERO + ACC1 = ZERO + ACC2 = ZERO +* + DO 85 I = 1, N1 - 1 + DLT = W( I ) / + $ ( ( DLAMBDA( I )-DLAMBDA( IORG ) ) - TAU( J ) ) + TEMP = TEMP + DLT*DLT + ACC1 = ACC1 + QIN( 1, I )*DLT + ACC2 = ACC2 + QIN( 2, I )*DLT + 85 CONTINUE +* + DLT = W( N1 ) / NEAR( 1, J ) + TEMP = TEMP + DLT*DLT + ACC1 = ACC1 + QIN( 1, N1 )*DLT + ACC2 = ACC2 + QIN( 2, N1 )*DLT +* + DO 86 I = N1 + 1, N2 - 1 + DLT = W( I ) / + $ ( ( DLAMBDA( I )-DLAMBDA( IORG ) ) - TAU( J ) ) + TEMP = TEMP + DLT*DLT + ACC1 = ACC1 + QIN( 1, I )*DLT + ACC2 = ACC2 + QIN( 2, I )*DLT + 86 CONTINUE +* + DLT = W( N2 ) / NEAR( 2, J ) + TEMP = TEMP + DLT*DLT + ACC1 = ACC1 + QIN( 1, N2 )*DLT + ACC2 = ACC2 + QIN( 2, N2 )*DLT +* + DO 87 I = N2 + 1, K + DLT = W( I ) / + $ ( ( DLAMBDA( I )-DLAMBDA( IORG ) ) - TAU( J ) ) + TEMP = TEMP + DLT*DLT + ACC1 = ACC1 + QIN( 1, I )*DLT + ACC2 = ACC2 + QIN( 2, I )*DLT + 87 CONTINUE +* + TEMP = SQRT( TEMP ) + QOUT( 1, J ) = ACC1 / TEMP + QOUT( 2, J ) = ACC2 / TEMP + 115 CONTINUE + GO TO 170 + END IF +* + DO 130 J = 1, K + IF( J.EQ.K ) THEN + IORG = K + ELSE IF( TAU( J ).GE.ZERO ) THEN + IORG = J + ELSE + IORG = J + 1 + END IF + TEMP = ZERO + DO 90 R = 1, NBR + QOUT( R, J ) = ZERO + 90 CONTINUE + DO 100 I = 1, K + DLT = ( DLAMBDA( I )-DLAMBDA( IORG ) ) - TAU( J ) + IF( J.EQ.K ) THEN + IF( I.EQ.K-1 ) + $ DLT = NEAR( 1, J ) + IF( I.EQ.K ) + $ DLT = NEAR( 2, J ) + ELSE + IF( I.EQ.J ) + $ DLT = NEAR( 1, J ) + IF( I.EQ.J+1 ) + $ DLT = NEAR( 2, J ) + END IF + DLT = W( I ) / DLT + TEMP = TEMP + DLT*DLT + DO 95 R = 1, NBR + QOUT( R, J ) = QOUT( R, J ) + QIN( R, I )*DLT + 95 CONTINUE + 100 CONTINUE + TEMP = SQRT( TEMP ) + DO 120 R = 1, NBR + QOUT( R, J ) = QOUT( R, J ) / TEMP + 120 CONTINUE + 130 CONTINUE +* + 170 CONTINUE + RETURN +* +* End of SLAED9_BR +* + END diff --git a/lapack-netlib/SRC/sstebr.c b/lapack-netlib/SRC/sstebr.c new file mode 100644 index 0000000000..0aa1c8f84b --- /dev/null +++ b/lapack-netlib/SRC/sstebr.c @@ -0,0 +1,525 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef blasint logical; + +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* Table of constant values */ + +static integer c__9 = 9; +static integer c__0 = 0; +static real c_b19 = 1.f; +static integer c__1 = 1; + +/* > \brief \b SSTEBR */ + +/* =========== DOCUMENTATION =========== */ + +/* Online html documentation available at */ +/* http://www.netlib.org/lapack/explore-html/ */ + +/* Definition: */ +/* =========== */ + +/* SUBROUTINE SSTEBR( N, D, E, WORK, LWORK, IWORK, LIWORK, INFO ) */ + +/* INTEGER INFO, LIWORK, LWORK, N */ +/* INTEGER IWORK( * ) */ +/* REAL D( * ), E( * ), WORK( * ) */ + + +/* > \par Purpose: */ +/* ============= */ +/* > */ +/* > \verbatim */ +/* > */ +/* > SSTEBR computes all eigenvalues of a symmetric tridiagonal matrix */ +/* > using a values-only divide-and-conquer method that propagates only */ +/* > the first and last boundary rows of each local eigenvector block */ +/* > (STEBR = Symmetric tridiagonal Eigenvalues, Boundary-Row DC). */ +/* > */ +/* > Unlike SSTEDC with COMPZ = 'N', SSTEBR does not store full secular */ +/* > eigenvector blocks across merge levels for later replay. It is a */ +/* > distinct routine and does not replace SSTEDC or SSTERF. */ +/* > */ +/* > \endverbatim */ + +/* Arguments: */ +/* ========== */ + +/* > \param[in] N */ +/* > \verbatim */ +/* > N is INTEGER */ +/* > The order of the matrix. N >= 0. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] D */ +/* > \verbatim */ +/* > D is REAL array, dimension (N) */ +/* > On entry, the n diagonal elements of the tridiagonal matrix. */ +/* > On exit, if INFO = 0, the eigenvalues in ascending order. */ +/* > \endverbatim */ +/* > */ +/* > \param[in,out] E */ +/* > \verbatim */ +/* > E is REAL array, dimension (N-1) */ +/* > On entry, the (n-1) subdiagonal elements of the tridiagonal */ +/* > matrix. */ +/* > On exit, E has been destroyed. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] WORK */ +/* > \verbatim */ +/* > WORK is REAL array, dimension (MAX(1,LWORK)) */ +/* > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LWORK */ +/* > \verbatim */ +/* > LWORK is INTEGER */ +/* > The dimension of the array WORK. */ +/* > If N <= SMLSIZ, where SMLSIZ is returned by ILAENV and is */ +/* > typically about 25, LWORK must be at least 1. */ +/* > If N > SMLSIZ, LWORK must be at least */ +/* > MAX( 16*N, 2*N + SMLSIZ**2 + 2*SMLSIZ - 2 ). */ +/* > */ +/* > If LWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the optimal sizes of the WORK and */ +/* > IWORK arrays, returns these values as the first entries of */ +/* > the WORK and IWORK arrays, and no error message related to */ +/* > LWORK or LIWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] IWORK */ +/* > \verbatim */ +/* > IWORK is INTEGER array, dimension (MAX(1,LIWORK)) */ +/* > On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. */ +/* > \endverbatim */ +/* > */ +/* > \param[in] LIWORK */ +/* > \verbatim */ +/* > LIWORK is INTEGER */ +/* > The dimension of the array IWORK. */ +/* > If N <= SMLSIZ, LIWORK must be at least 1. */ +/* > If N > SMLSIZ, LIWORK must be at least 7*N. */ +/* > */ +/* > If LIWORK = -1, then a workspace query is assumed; the */ +/* > routine only calculates the optimal sizes of the WORK and */ +/* > IWORK arrays, returns these values as the first entries of */ +/* > the WORK and IWORK arrays, and no error message related to */ +/* > LWORK or LIWORK is issued by XERBLA. */ +/* > \endverbatim */ +/* > */ +/* > \param[out] INFO */ +/* > \verbatim */ +/* > INFO is INTEGER */ +/* > = 0: successful exit. */ +/* > < 0: if INFO = -i, the i-th argument had an illegal value. */ +/* > > 0: The algorithm failed to compute an eigenvalue while */ +/* > working on a submatrix lying in rows and columns */ +/* > INFO/(N+1) through MOD(INFO,N+1). */ +/* > \endverbatim */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \ingroup stebr */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science */ +/* > and Technology of China */ + +/* ===================================================================== */ +/* Subroutine */ void sstebr_(integer *n, real *d__, real *e, real *work, + integer *lwork, integer *iwork, integer *liwork, integer *info) +{ + /* System generated locals */ + integer i__1, i__2; + real r__1, r__2; + + /* Local variables */ + extern /* Subroutine */ void slaed0_br_(integer *, real *, real *, real *, + integer *, integer *); + integer m; + real eps, tiny; + integer lwmin, start; + extern real slamch_(char *); + extern /* Subroutine */ void xerbla_(char *, integer *, ftnlen); + extern integer ilaenv_(integer *, char *, char *, integer *, integer *, + integer *, integer *, ftnlen, ftnlen); + integer finish; + extern /* Subroutine */ void slascl_(char *, integer *, integer *, real *, + real *, integer *, integer *, real *, integer *, integer *); + integer liwmin; + real orgnrm; + extern real slanst_(char *, integer *, real *, real *); + extern /* Subroutine */ void ssterf_(integer *, real *, real *, integer *), + slasrt_(char *, integer *, real *, integer *); + logical lquery; + integer smlsiz; + extern real sroundup_lwork__(integer *); + + +/* -- LAPACK computational routine -- */ + + +/* ===================================================================== */ + + + /* Parameter adjustments */ + --iwork; + --work; + --e; + --d__; + + /* Function Body */ + *info = 0; + lquery = *lwork == -1 || *liwork == -1; + + if (*n < 0) { + *info = -1; + } + + if (*info == 0) { + smlsiz = ilaenv_(&c__9, "SSTEBR", " ", &c__0, &c__0, &c__0, &c__0, ( + ftnlen)6, (ftnlen)1); + if (*n <= smlsiz) { + lwmin = 1; + liwmin = 1; + } else { + +/* BLO/BHI: 2*N; merge scratch: 14*N (see SLAED7_BR). */ +/* Leaf solves need 2*N + SMLSIZ**2 + 2*SMLSIZ - 2: the */ +/* SMLSIZ-by-SMLSIZ leaf eigenvector block plus the */ +/* SSTEQR work array. */ + +/* Computing MAX */ + i__1 = *n << 4, i__2 = (*n << 1) + smlsiz * smlsiz + (smlsiz << 1) + - 2; + lwmin = f2cmax(i__1,i__2); +/* Computing MAX */ + i__1 = 1, i__2 = *n * 7; + liwmin = f2cmax(i__1,i__2); + } + work[1] = sroundup_lwork__(&lwmin); + iwork[1] = liwmin; + + if (*lwork < lwmin && ! lquery) { + *info = -5; + } else if (*liwork < liwmin && ! lquery) { + *info = -7; + } + } + + if (*info != 0) { + i__1 = -(*info); + xerbla_("SSTEBR", &i__1, (ftnlen)6); + return; + } else if (lquery) { + return; + } + + if (*n == 0) { + return; + } + if (*n == 1) { + return; + } + + if (*n <= smlsiz) { + ssterf_(n, &d__[1], &e[1], info); + goto L50; + } + + orgnrm = slanst_("M", n, &d__[1], &e[1]); + if (orgnrm <= 0.f) { + goto L50; + } + + eps = slamch_("Epsilon"); + start = 1; + +L10: + if (start <= *n) { + finish = start; +L20: + if (finish < *n) { + tiny = eps * sqrt((r__1 = d__[finish], abs(r__1))) * sqrt((r__2 = + d__[finish + 1], abs(r__2))); + if ((r__1 = e[finish], abs(r__1)) > tiny) { + ++finish; + goto L20; + } + } + + m = finish - start + 1; + if (m == 1) { + start = finish + 1; + goto L10; + } + + if (m > smlsiz) { + orgnrm = slanst_("M", &m, &d__[start], &e[start]); + slascl_("G", &c__0, &c__0, &orgnrm, &c_b19, &m, &c__1, &d__[start] + , &m, info); + i__1 = m - 1; + i__2 = m - 1; + slascl_("G", &c__0, &c__0, &orgnrm, &c_b19, &i__1, &c__1, &e[ + start], &i__2, info); + + slaed0_br_(&m, &d__[start], &e[start], &work[1], &iwork[1], info) + ; + if (*info != 0) { + *info = (*info / (m + 1) + start - 1) * (*n + 1) + *info % (m + + 1) + start - 1; + goto L50; + } + + slascl_("G", &c__0, &c__0, &c_b19, &orgnrm, &m, &c__1, &d__[start] + , &m, info); + } else { + ssterf_(&m, &d__[start], &e[start], info); + if (*info != 0) { + *info = start * (*n + 1) + finish; + goto L50; + } + } + + start = finish + 1; + goto L10; + } + + slasrt_("I", n, &d__[1], info); + +L50: + work[1] = sroundup_lwork__(&lwmin); + iwork[1] = liwmin; + return; + +/* End of SSTEBR */ + +} /* sstebr_ */ + diff --git a/lapack-netlib/SRC/sstebr.f b/lapack-netlib/SRC/sstebr.f new file mode 100644 index 0000000000..21178f905c --- /dev/null +++ b/lapack-netlib/SRC/sstebr.f @@ -0,0 +1,280 @@ +*> \brief \b SSTEBR +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ +* +* Definition: +* =========== +* +* SUBROUTINE SSTEBR( N, D, E, WORK, LWORK, IWORK, LIWORK, INFO ) +* +* .. Scalar Arguments .. +* INTEGER INFO, LIWORK, LWORK, N +* .. +* .. Array Arguments .. +* INTEGER IWORK( * ) +* REAL D( * ), E( * ), WORK( * ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> SSTEBR computes all eigenvalues of a symmetric tridiagonal matrix +*> using a values-only divide-and-conquer method that propagates only +*> the first and last boundary rows of each local eigenvector block +*> (STEBR = Symmetric tridiagonal Eigenvalues, Boundary-Row DC). +*> +*> Unlike SSTEDC with COMPZ = 'N', SSTEBR does not store full secular +*> eigenvector blocks across merge levels for later replay. It is a +*> distinct routine and does not replace SSTEDC or SSTERF. +*> +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The order of the matrix. N >= 0. +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is REAL array, dimension (N) +*> On entry, the n diagonal elements of the tridiagonal matrix. +*> On exit, if INFO = 0, the eigenvalues in ascending order. +*> \endverbatim +*> +*> \param[in,out] E +*> \verbatim +*> E is REAL array, dimension (N-1) +*> On entry, the (n-1) subdiagonal elements of the tridiagonal +*> matrix. +*> On exit, E has been destroyed. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is REAL array, dimension (MAX(1,LWORK)) +*> On exit, if INFO = 0, WORK(1) returns the optimal LWORK. +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> The dimension of the array WORK. +*> If N <= SMLSIZ, where SMLSIZ is returned by ILAENV and is +*> typically about 25, LWORK must be at least 1. +*> If N > SMLSIZ, LWORK must be at least +*> MAX( 16*N, 2*N + SMLSIZ**2 + 2*SMLSIZ - 2 ). +*> +*> If LWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK and IWORK arrays, and no error message related to +*> LWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] IWORK +*> \verbatim +*> IWORK is INTEGER array, dimension (MAX(1,LIWORK)) +*> On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK. +*> \endverbatim +*> +*> \param[in] LIWORK +*> \verbatim +*> LIWORK is INTEGER +*> The dimension of the array IWORK. +*> If N <= SMLSIZ, LIWORK must be at least 1. +*> If N > SMLSIZ, LIWORK must be at least 7*N. +*> +*> If LIWORK = -1, then a workspace query is assumed; the +*> routine only calculates the optimal sizes of the WORK and +*> IWORK arrays, returns these values as the first entries of +*> the WORK and IWORK arrays, and no error message related to +*> LWORK or LIWORK is issued by XERBLA. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, the i-th argument had an illegal value. +*> > 0: The algorithm failed to compute an eigenvalue while +*> working on a submatrix lying in rows and columns +*> INFO/(N+1) through MOD(INFO,N+1). +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup stebr +* +*> \par Contributors: +* ================== +*> +*> Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science +*> and Technology of China +* +* ===================================================================== + SUBROUTINE SSTEBR( N, D, E, WORK, LWORK, IWORK, LIWORK, INFO ) +* +* -- LAPACK computational routine -- +* +* .. Scalar Arguments .. + INTEGER INFO, LIWORK, LWORK, N +* .. +* .. Array Arguments .. + INTEGER IWORK( * ) + REAL D( * ), E( * ), WORK( * ) +* .. +* +* ===================================================================== +* +* .. Parameters .. + REAL ZERO, ONE + PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 ) +* .. +* .. Local Scalars .. + LOGICAL LQUERY + INTEGER FINISH, LIWMIN, LWMIN, M, SMLSIZ, START + REAL EPS, ORGNRM, TINY +* .. +* .. External Functions .. + INTEGER ILAENV + REAL SLAMCH, SLANST, SROUNDUP_LWORK + EXTERNAL ILAENV, SLAMCH, SLANST, SROUNDUP_LWORK +* .. +* .. External Subroutines .. + EXTERNAL SLAED0_BR, SLASCL, SLASRT, SSTERF, XERBLA +* .. +* .. Intrinsic Functions .. + INTRINSIC ABS, MAX, MOD, SQRT +* .. +* .. Executable Statements .. +* + INFO = 0 + LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 ) +* + IF( N.LT.0 ) THEN + INFO = -1 + END IF +* + IF( INFO.EQ.0 ) THEN + SMLSIZ = ILAENV( 9, 'SSTEBR', ' ', 0, 0, 0, 0 ) + IF( N.LE.SMLSIZ ) THEN + LWMIN = 1 + LIWMIN = 1 + ELSE +* +* BLO/BHI: 2*N; merge scratch: 14*N (see SLAED7_BR). +* Leaf solves need 2*N + SMLSIZ**2 + 2*SMLSIZ - 2: the +* SMLSIZ-by-SMLSIZ leaf eigenvector block plus the +* SSTEQR work array. +* + LWMIN = MAX( 16*N, 2*N + SMLSIZ*SMLSIZ + 2*SMLSIZ - 2 ) + LIWMIN = MAX( 1, 7*N ) + END IF + WORK( 1 ) = SROUNDUP_LWORK( LWMIN ) + IWORK( 1 ) = LIWMIN +* + IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN + INFO = -5 + ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN + INFO = -7 + END IF + END IF +* + IF( INFO.NE.0 ) THEN + CALL XERBLA( 'SSTEBR', -INFO ) + RETURN + ELSE IF( LQUERY ) THEN + RETURN + END IF +* + IF( N.EQ.0 ) + $ RETURN + IF( N.EQ.1 ) + $ RETURN +* + IF( N.LE.SMLSIZ ) THEN + CALL SSTERF( N, D, E, INFO ) + GO TO 50 + END IF +* + ORGNRM = SLANST( 'M', N, D, E ) + IF( ORGNRM.LE.ZERO ) + $ GO TO 50 +* + EPS = SLAMCH( 'Epsilon' ) + START = 1 +* + 10 CONTINUE + IF( START.LE.N ) THEN + FINISH = START + 20 CONTINUE + IF( FINISH.LT.N ) THEN + TINY = EPS*SQRT( ABS( D( FINISH ) ) )* + $ SQRT( ABS( D( FINISH+1 ) ) ) + IF( ABS( E( FINISH ) ).GT.TINY ) THEN + FINISH = FINISH + 1 + GO TO 20 + END IF + END IF +* + M = FINISH - START + 1 + IF( M.EQ.1 ) THEN + START = FINISH + 1 + GO TO 10 + END IF +* + IF( M.GT.SMLSIZ ) THEN + ORGNRM = SLANST( 'M', M, D( START ), E( START ) ) + CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), + $ M, INFO ) + CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, + $ E( START ), M-1, INFO ) +* + CALL SLAED0_BR( M, D( START ), E( START ), WORK, IWORK, + $ INFO ) + IF( INFO.NE.0 ) THEN + INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) + + $ MOD( INFO, ( M+1 ) ) + START - 1 + GO TO 50 + END IF +* + CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), + $ M, INFO ) + ELSE + CALL SSTERF( M, D( START ), E( START ), INFO ) + IF( INFO.NE.0 ) THEN + INFO = START*( N+1 ) + FINISH + GO TO 50 + END IF + END IF +* + START = FINISH + 1 + GO TO 10 + END IF +* + CALL SLASRT( 'I', N, D, INFO ) +* + 50 CONTINUE + WORK( 1 ) = SROUNDUP_LWORK( LWMIN ) + IWORK( 1 ) = LIWMIN + RETURN +* +* End of SSTEBR +* + END diff --git a/lapack-netlib/SRC/ssteqr_boundary_br.c b/lapack-netlib/SRC/ssteqr_boundary_br.c new file mode 100644 index 0000000000..231e494ed5 --- /dev/null +++ b/lapack-netlib/SRC/ssteqr_boundary_br.c @@ -0,0 +1,277 @@ +#include +#include +#include +#include +#include +#ifdef complex +#undef complex +#endif +#ifdef I +#undef I +#endif + +#if defined(_WIN64) +typedef long long BLASLONG; +typedef unsigned long long BLASULONG; +#else +typedef long BLASLONG; +typedef unsigned long BLASULONG; +#endif + +#ifdef LAPACK_ILP64 +typedef BLASLONG blasint; +#if defined(_WIN64) +#define blasabs(x) llabs(x) +#else +#define blasabs(x) labs(x) +#endif +#else +typedef int blasint; +#define blasabs(x) abs(x) +#endif + +typedef blasint integer; + +typedef unsigned int uinteger; +typedef char *address; +typedef short int shortint; +typedef float real; +typedef double doublereal; +typedef struct { real r, i; } complex; +typedef struct { doublereal r, i; } doublecomplex; +typedef blasint logical; + +typedef char logical1; +typedef char integer1; + +#define TRUE_ (1) +#define FALSE_ (0) + +/* Extern is for use with -E */ +#ifndef Extern +#define Extern extern +#endif + +/* I/O stuff */ + +typedef int flag; +typedef int ftnlen; +typedef int ftnint; + +/*external read, write*/ +typedef struct +{ flag cierr; + ftnint ciunit; + flag ciend; + char *cifmt; + ftnint cirec; +} cilist; + +/*internal read, write*/ +typedef struct +{ flag icierr; + char *iciunit; + flag iciend; + char *icifmt; + ftnint icirlen; + ftnint icirnum; +} icilist; + +/*open*/ +typedef struct +{ flag oerr; + ftnint ounit; + char *ofnm; + ftnlen ofnmlen; + char *osta; + char *oacc; + char *ofm; + ftnint orl; + char *oblnk; +} olist; + +/*close*/ +typedef struct +{ flag cerr; + ftnint cunit; + char *csta; +} cllist; + +/*rewind, backspace, endfile*/ +typedef struct +{ flag aerr; + ftnint aunit; +} alist; + +/* inquire */ +typedef struct +{ flag inerr; + ftnint inunit; + char *infile; + ftnlen infilen; + ftnint *inex; /*parameters in standard's order*/ + ftnint *inopen; + ftnint *innum; + ftnint *innamed; + char *inname; + ftnlen innamlen; + char *inacc; + ftnlen inacclen; + char *inseq; + ftnlen inseqlen; + char *indir; + ftnlen indirlen; + char *infmt; + ftnlen infmtlen; + char *inform; + ftnint informlen; + char *inunf; + ftnlen inunflen; + ftnint *inrecl; + ftnint *innrec; + char *inblank; + ftnlen inblanklen; +} inlist; + +#define VOID void + +union Multitype { /* for multiple entry points */ + integer1 g; + shortint h; + integer i; + /* longint j; */ + real r; + doublereal d; + complex c; + doublecomplex z; + }; + +typedef union Multitype Multitype; + +struct Vardesc { /* for Namelist */ + char *name; + char *addr; + ftnlen *dims; + int type; + }; +typedef struct Vardesc Vardesc; + +struct Namelist { + char *name; + Vardesc **vars; + int nvars; + }; +typedef struct Namelist Namelist; + +#define abs(x) ((x) >= 0 ? (x) : -(x)) +#define dabs(x) (fabs(x)) +#define f2cmin(a,b) ((a) <= (b) ? (a) : (b)) +#define f2cmax(a,b) ((a) >= (b) ? (a) : (b)) +#define dmin(a,b) (f2cmin(a,b)) +#define dmax(a,b) (f2cmax(a,b)) +#define bit_test(a,b) ((a) >> (b) & 1) +#define bit_clear(a,b) ((a) & ~((uinteger)1 << (b))) +#define bit_set(a,b) ((a) | ((uinteger)1 << (b))) + +#define abort_() { sig_die("Fortran abort routine called", 1); } +#define d_abs(x) (fabs(*(x))) +#define d_acos(x) (acos(*(x))) +#define d_asin(x) (asin(*(x))) +#define d_atan(x) (atan(*(x))) +#define d_atn2(x, y) (atan2(*(x),*(y))) +#define d_cos(x) (cos(*(x))) +#define d_cosh(x) (cosh(*(x))) +#define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 ) +#define d_exp(x) (exp(*(x))) +#define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x))) +#define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) ) +#define d_log(x) (log(*(x))) +#define d_mod(x, y) (fmod(*(x), *(y))) +#define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x))) +#define d_nint(x) u_nint(*(x)) +#define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a))) +#define d_sign(a,b) u_sign(*(a),*(b)) +#define r_sign(a,b) u_sign(*(a),*(b)) +#define d_sin(x) (sin(*(x))) +#define d_sinh(x) (sinh(*(x))) +#define d_sqrt(x) (sqrt(*(x))) +#define d_tan(x) (tan(*(x))) +#define d_tanh(x) (tanh(*(x))) +#define i_abs(x) abs(*(x)) +#define i_dnnt(x) ((integer)u_nint(*(x))) +#define i_len(s, n) (n) +#define i_nint(x) ((integer)u_nint(*(x))) +#define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b))) +#define pow_dd(ap, bp) ( pow(*(ap), *(bp))) +#define pow_si(B,E) spow_ui(*(B),*(E)) +#define pow_ri(B,E) spow_ui(*(B),*(E)) +#define pow_di(B,E) dpow_ui(*(B),*(E)) +#define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; } +#define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d)))) +#define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; } +#define sig_die(s, kill) { exit(1); } +#define s_stop(s, n) {exit(0);} +#define myexit_() break; +#define mycycle() continue; +#define myceiling(w) {ceil(w)} +#define myhuge(w) {HUGE_VAL} +//#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);} +#define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)} + +/* > \brief \b SSTEQR_BOUNDARY_BR solves one leaf and keeps boundary rows. */ + +/* Authors: */ +/* ======== */ + +/* > \author Univ. of Tennessee */ +/* > \author Univ. of California Berkeley */ +/* > \author Univ. of Colorado Denver */ +/* > \author NAG Ltd. */ + +/* > \ingroup stebr */ + +/* > \par Contributors: */ +/* ================== */ +/* > */ +/* > Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science */ +/* > and Technology of China */ + +/* Subroutine */ void ssteqr_boundary_br_(integer *n, real *d__, real *e, + real *blo, real *bhi, real *q, integer *ldq, real *work, integer * + info) +{ + /* System generated locals */ + integer i__1; + + /* Local variables */ + integer j; + extern /* Subroutine */ void ssteqr_(char *, integer *, real *, real *, + real *, integer *, real *, integer *); + + + + /* Parameter adjustments */ + --work; + --q; + --bhi; + --blo; + --e; + --d__; + + /* Function Body */ + ssteqr_("I", n, &d__[1], &e[1], &q[1], ldq, &work[1], info); + if (*info != 0) { + return; + } + + i__1 = *n; + for (j = 1; j <= i__1; ++j) { + blo[j] = q[(j - 1) * *ldq + 1]; + bhi[j] = q[*n + (j - 1) * *ldq]; +/* L10: */ + } + return; +} /* ssteqr_boundary_br__ */ + diff --git a/lapack-netlib/SRC/ssteqr_boundary_br.f b/lapack-netlib/SRC/ssteqr_boundary_br.f new file mode 100644 index 0000000000..fcae55a586 --- /dev/null +++ b/lapack-netlib/SRC/ssteqr_boundary_br.f @@ -0,0 +1,36 @@ +*> \brief \b SSTEQR_BOUNDARY_BR solves one leaf and keeps boundary rows. +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup stebr +* +*> \par Contributors: +* ================== +*> +*> Ruiyi Zhan and Shaoshuai Zhang, University of Electronic Science +*> and Technology of China +* + SUBROUTINE SSTEQR_BOUNDARY_BR( N, D, E, BLO, BHI, Q, LDQ, WORK, + $ INFO ) +* + INTEGER INFO, J, LDQ, N + REAL BLO( * ), BHI( * ), D( * ), E( * ), Q( * ), + $ WORK( * ) + EXTERNAL SSTEQR +* + CALL SSTEQR( 'I', N, D, E, Q, LDQ, WORK, INFO ) + IF( INFO.NE.0 ) + $ RETURN +* + DO 10 J = 1, N + BLO( J ) = Q( 1 + ( J - 1 )*LDQ ) + BHI( J ) = Q( N + ( J - 1 )*LDQ ) + 10 CONTINUE + RETURN + END diff --git a/lapack-netlib/TESTING/EIG/dchkst.f b/lapack-netlib/TESTING/EIG/dchkst.f index 6e02c84fbb..95fa26c9d0 100644 --- a/lapack-netlib/TESTING/EIG/dchkst.f +++ b/lapack-netlib/TESTING/EIG/dchkst.f @@ -152,6 +152,10 @@ *> (26) | D1 - D2 | / ( |D1| ulp ) DSTEDC('V') and *> DSTEDC('N') *> +*> (38) | D1 - D5 | / ( |D1| ulp ) DSTEBR +*> (values-only boundary-row divide-and-conquer) +*> Maximum over SMLSIZ = 2, 8, and 25. +*> *> Test 27 is disabled at the moment because DSTEMR does not *> guarantee high relatvie accuracy. *> @@ -588,6 +592,7 @@ SUBROUTINE DCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5, $ WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, $ LWORK, IWORK, LIWORK, RESULT, INFO ) + IMPLICIT NONE * * -- LAPACK test routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -626,9 +631,10 @@ SUBROUTINE DCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * .. Local Scalars .. LOGICAL BADNN, TRYRAC INTEGER I, IINFO, IL, IMODE, ITEMP, ITYPE, IU, J, JC, - $ JR, JSIZE, JTYPE, LGN, LIWEDC, LOG2UI, LWEDC, - $ M, M2, M3, MTYPES, N, NAP, NBLOCK, NERRS, - $ NMATS, NMAX, NSPLIT, NTEST, NTESTT + $ JR, JSIZE, JSM, JTYPE, LGN, LIWEDC, LOG2UI, + $ LWEDC, M, M2, M3, MTYPES, N, NAP, NBLOCK, + $ NERRS, NMATS, NMAX, NSPLIT, NTEST, NTESTT, + $ SMLSAV DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, $ RTUNFL, TEMP1, TEMP2, TEMP3, TEMP4, ULP, $ ULPINV, UNFL, VL, VU @@ -636,7 +642,7 @@ SUBROUTINE DCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * .. Local Arrays .. INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), $ KMAGN( MAXTYP ), KMODE( MAXTYP ), - $ KTYPE( MAXTYP ) + $ KTYPE( MAXTYP ), SMLSZS( 3 ) DOUBLE PRECISION DUMMA( 1 ) * .. * .. External Functions .. @@ -647,13 +653,15 @@ SUBROUTINE DCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * .. External Subroutines .. EXTERNAL DCOPY, DLACPY, DLASET, DLASUM, DLATMR, DLATMS, $ DOPGTR, DORGTR, DPTEQR, DSPT21, DSPTRD, DSTEBZ, - $ DSTECH, DSTEDC, DSTEMR, DSTEIN, DSTEQR, DSTERF, - $ DSTT21, DSTT22, DSYT21, DSYTRD, XERBLA + $ DSTEBR, DSTECH, DSTEDC, DSTEMR, DSTEIN, DSTEQR, + $ DSTERF, DSTT21, DSTT22, DSYT21, DSYTRD, + $ XERBLA, XLAENV * .. * .. Intrinsic Functions .. INTRINSIC ABS, DBLE, INT, LOG, MAX, MIN, SQRT * .. * .. Data statements .. + DATA SMLSZS / 2, 8, 25 / DATA KTYPE / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8, $ 8, 8, 9, 9, 9, 9, 9, 10 / DATA KMAGN / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, @@ -1336,8 +1344,8 @@ SUBROUTINE DCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, IL = 1 IU = N ELSE - IL = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) - IU = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) + IL = 1 + INT( N*DLARND( 1, ISEED2 ) ) + IU = 1 + INT( N*DLARND( 1, ISEED2 ) ) IF( IU.LT.IL ) THEN ITEMP = IU IU = IL @@ -1597,8 +1605,8 @@ SUBROUTINE DCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * RESULT( 27 ) = TEMP1 / TEMP2 * - IL = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) - IU = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) + IL = 1 + INT( N*DLARND( 1, ISEED2 ) ) + IU = 1 + INT( N*DLARND( 1, ISEED2 ) ) IF( IU.LT.IL ) THEN ITEMP = IU IU = IL @@ -1657,8 +1665,8 @@ SUBROUTINE DCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * IF( SRANGE ) THEN NTEST = 29 - IL = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) - IU = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) ) + IL = 1 + INT( N*DLARND( 1, ISEED2 ) ) + IU = 1 + INT( N*DLARND( 1, ISEED2 ) ) IF( IU.LT.IL ) THEN ITEMP = IU IU = IL @@ -1897,6 +1905,52 @@ SUBROUTINE DCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ULP*MAX( TEMP1, TEMP2 ) ) END IF 270 CONTINUE +* +* Call DSTEBR (values-only boundary-row DC), do test 38. +* Compare against D1 from DSTEQR('V'), same ratio as tests +* 12 and 26. Vary SMLSIZ to exercise merges even with the +* small matrix sizes in sep.in, and retain the worst ratio. +* + DO 265 JR = NTEST + 1, 37 + RESULT( JR ) = ZERO + 265 CONTINUE +* + NTEST = 38 + RESULT( 38 ) = ZERO + SMLSAV = ILAENV( 9, 'DSTEBR', ' ', 0, 0, 0, 0 ) + DO 267 JSM = 1, 3 + CALL DCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL DCOPY( N-1, SE, 1, WORK, 1 ) +* + CALL XLAENV( 9, SMLSZS( JSM ) ) + CALL DSTEBR( N, D5, WORK, WORK( N+1 ), LWORK-N, + $ IWORK, LIWORK, IINFO ) + CALL XLAENV( 9, SMLSAV ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'DSTEBR', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 38 ) = ULPINV + GO TO 280 + END IF + END IF +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 266 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D5( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D5( J ) ) ) + 266 CONTINUE +* + RESULT( 38 ) = MAX( RESULT( 38 ), TEMP2 / + $ MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) ) + 267 CONTINUE +* 280 CONTINUE NTESTT = NTESTT + NTEST * diff --git a/lapack-netlib/TESTING/EIG/schkst.f b/lapack-netlib/TESTING/EIG/schkst.f index aecbdfe932..7f251eb561 100644 --- a/lapack-netlib/TESTING/EIG/schkst.f +++ b/lapack-netlib/TESTING/EIG/schkst.f @@ -152,6 +152,10 @@ *> (26) | D1 - D2 | / ( |D1| ulp ) SSTEDC('V') and *> SSTEDC('N') *> +*> (38) | D1 - D5 | / ( |D1| ulp ) SSTEBR +*> (values-only boundary-row divide-and-conquer) +*> Maximum over SMLSIZ = 2, 8, and 25. +*> *> Test 27 is disabled at the moment because SSTEMR does not *> guarantee high relatvie accuracy. *> @@ -588,6 +592,7 @@ SUBROUTINE SCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5, $ WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK, $ LWORK, IWORK, LIWORK, RESULT, INFO ) + IMPLICIT NONE * * -- LAPACK test routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- @@ -626,9 +631,10 @@ SUBROUTINE SCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * .. Local Scalars .. LOGICAL BADNN, TRYRAC INTEGER I, IINFO, IL, IMODE, ITEMP, ITYPE, IU, J, JC, - $ JR, JSIZE, JTYPE, LGN, LIWEDC, LOG2UI, LWEDC, - $ M, M2, M3, MTYPES, N, NAP, NBLOCK, NERRS, - $ NMATS, NMAX, NSPLIT, NTEST, NTESTT + $ JR, JSIZE, JSM, JTYPE, LGN, LIWEDC, LOG2UI, + $ LWEDC, M, M2, M3, MTYPES, N, NAP, NBLOCK, + $ NERRS, NMATS, NMAX, NSPLIT, NTEST, NTESTT, + $ SMLSAV REAL ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL, $ RTUNFL, TEMP1, TEMP2, TEMP3, TEMP4, ULP, $ ULPINV, UNFL, VL, VU @@ -636,7 +642,7 @@ SUBROUTINE SCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * .. Local Arrays .. INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ), $ KMAGN( MAXTYP ), KMODE( MAXTYP ), - $ KTYPE( MAXTYP ) + $ KTYPE( MAXTYP ), SMLSZS( 3 ) REAL DUMMA( 1 ) * .. * .. External Functions .. @@ -647,13 +653,15 @@ SUBROUTINE SCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * .. External Subroutines .. EXTERNAL SCOPY, SLACPY, SLASET, SLASUM, SLATMR, SLATMS, $ SOPGTR, SORGTR, SPTEQR, SSPT21, SSPTRD, SSTEBZ, - $ SSTECH, SSTEDC, SSTEMR, SSTEIN, SSTEQR, SSTERF, - $ SSTT21, SSTT22, SSYT21, SSYTRD, XERBLA + $ SSTEBR, SSTECH, SSTEDC, SSTEMR, SSTEIN, SSTEQR, + $ SSTERF, SSTT21, SSTT22, SSYT21, SSYTRD, + $ XERBLA, XLAENV * .. * .. Intrinsic Functions .. INTRINSIC ABS, INT, LOG, MAX, MIN, REAL, SQRT * .. * .. Data statements .. + DATA SMLSZS / 2, 8, 25 / DATA KTYPE / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8, $ 8, 8, 9, 9, 9, 9, 9, 10 / DATA KMAGN / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1, @@ -797,7 +805,7 @@ SUBROUTINE SCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, GO TO 70 * 60 CONTINUE - ANORM = RTUNFL*N*ULPINV + ANORM = RTUNFL*REAL( N )*ULPINV GO TO 70 * 70 CONTINUE @@ -1284,8 +1292,8 @@ SUBROUTINE SCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * * Do test 17 * - TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) / - $ ( ONE-HALF )**4 + TEMP2 = TWO*( TWO*REAL( N )-ONE )*ULP* + $ ( ONE+EIGHT*HALF**2 ) / ( ONE-HALF )**4 * TEMP1 = ZERO DO 190 J = 1, N @@ -1336,8 +1344,8 @@ SUBROUTINE SCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, IL = 1 IU = N ELSE - IL = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) - IU = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) + IL = 1 + INT( REAL( N )*SLARND( 1, ISEED2 ) ) + IU = 1 + INT( REAL( N )*SLARND( 1, ISEED2 ) ) IF( IU.LT.IL ) THEN ITEMP = IU IU = IL @@ -1586,8 +1594,8 @@ SUBROUTINE SCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * * Do test 27 * - TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) / - $ ( ONE-HALF )**4 + TEMP2 = TWO*( TWO*REAL( N )-ONE )*ULP* + $ ( ONE+EIGHT*HALF**2 ) / ( ONE-HALF )**4 * TEMP1 = ZERO DO 220 J = 1, N @@ -1597,8 +1605,8 @@ SUBROUTINE SCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * RESULT( 27 ) = TEMP1 / TEMP2 * - IL = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) - IU = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) + IL = 1 + INT( REAL( N )*SLARND( 1, ISEED2 ) ) + IU = 1 + INT( REAL( N )*SLARND( 1, ISEED2 ) ) IF( IU.LT.IL ) THEN ITEMP = IU IU = IL @@ -1628,7 +1636,7 @@ SUBROUTINE SCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * * Do test 28 * - TEMP2 = TWO*( TWO*N-ONE )*ULP* + TEMP2 = TWO*( TWO*REAL( N )-ONE )*ULP* $ ( ONE+EIGHT*HALF**2 ) / ( ONE-HALF )**4 * TEMP1 = ZERO @@ -1657,8 +1665,8 @@ SUBROUTINE SCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, * IF( SRANGE ) THEN NTEST = 29 - IL = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) - IU = 1 + ( N-1 )*INT( SLARND( 1, ISEED2 ) ) + IL = 1 + INT( REAL( N )*SLARND( 1, ISEED2 ) ) + IU = 1 + INT( REAL( N )*SLARND( 1, ISEED2 ) ) IF( IU.LT.IL ) THEN ITEMP = IU IU = IL @@ -1897,6 +1905,52 @@ SUBROUTINE SCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH, $ ULP*MAX( TEMP1, TEMP2 ) ) END IF 270 CONTINUE +* +* Call SSTEBR (values-only boundary-row DC), do test 38. +* Compare against D1 from SSTEQR('V'), same ratio as tests +* 12 and 26. Vary SMLSIZ to exercise merges even with the +* small matrix sizes in sep.in, and retain the worst ratio. +* + DO 265 JR = NTEST + 1, 37 + RESULT( JR ) = ZERO + 265 CONTINUE +* + NTEST = 38 + RESULT( 38 ) = ZERO + SMLSAV = ILAENV( 9, 'SSTEBR', ' ', 0, 0, 0, 0 ) + DO 267 JSM = 1, 3 + CALL SCOPY( N, SD, 1, D5, 1 ) + IF( N.GT.0 ) + $ CALL SCOPY( N-1, SE, 1, WORK, 1 ) +* + CALL XLAENV( 9, SMLSZS( JSM ) ) + CALL SSTEBR( N, D5, WORK, WORK( N+1 ), LWORK-N, + $ IWORK, LIWORK, IINFO ) + CALL XLAENV( 9, SMLSAV ) + IF( IINFO.NE.0 ) THEN + WRITE( NOUNIT, FMT = 9999 )'SSTEBR', IINFO, N, + $ JTYPE, IOLDSD + INFO = ABS( IINFO ) + IF( IINFO.LT.0 ) THEN + RETURN + ELSE + RESULT( 38 ) = ULPINV + GO TO 280 + END IF + END IF +* + TEMP1 = ZERO + TEMP2 = ZERO +* + DO 266 J = 1, N + TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D5( J ) ) ) + TEMP2 = MAX( TEMP2, ABS( D1( J )-D5( J ) ) ) + 266 CONTINUE +* + RESULT( 38 ) = MAX( RESULT( 38 ), TEMP2 / + $ MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) ) ) + 267 CONTINUE +* 280 CONTINUE NTESTT = NTESTT + NTEST *