libflame  revision_anchor
Functions
FLA_Hevdr_external.c File Reference

(r)

Functions

FLA_Error FLA_Hevdr_external (FLA_Evd_type jobz, FLA_Uplo uplo, FLA_Obj A, FLA_Obj l, FLA_Obj Z)
 

Function Documentation

◆ FLA_Hevdr_external()

FLA_Error FLA_Hevdr_external ( FLA_Evd_type  jobz,
FLA_Uplo  uplo,
FLA_Obj  A,
FLA_Obj  l,
FLA_Obj  Z 
)
14 {
15  int info = 0;
16 #ifdef FLA_ENABLE_EXTERNAL_LAPACK_INTERFACES
17  FLA_Datatype datatype;
18  FLA_Datatype dt_real;
19  int n_A, cs_A;
20  int cs_Z;
21  int lwork, lrwork, liwork, lisuppz;
22  FLA_Obj work, rwork, iwork, isuppz, abstol;
23  char blas_jobz;
24  char blas_uplo;
25  int i;
26 
27  char blas_range = 'A';
28  int il, iu;
29  int eigs_found;
30 
31  if ( FLA_Check_error_level() == FLA_FULL_ERROR_CHECKING )
32  FLA_Hevdr_check( jobz, uplo, A, l, Z );
33 
34  if ( FLA_Obj_has_zero_dim( A ) ) return FLA_SUCCESS;
35 
36  datatype = FLA_Obj_datatype( A );
37  dt_real = FLA_Obj_datatype_proj_to_real( A );
38 
39  n_A = FLA_Obj_width( A );
40  cs_A = FLA_Obj_col_stride( A );
41  cs_Z = FLA_Obj_col_stride( Z );
42 
43  FLA_Param_map_flame_to_netlib_evd_type( jobz, &blas_jobz );
44  FLA_Param_map_flame_to_netlib_uplo( uplo, &blas_uplo );
45 
46  lisuppz = 2 * n_A;
47  FLA_Obj_create( FLA_INT, lisuppz, 1, 0, 0, &isuppz );
48  FLA_Obj_create( dt_real, 1, 1, 0, 0, &abstol );
49 
50  // Query the safe minimum to use as the abstol parameter.
51  FLA_Mach_params( FLA_MACH_SFMIN, abstol );
52 
53  // Make a workspace query the first time through. This will provide us with
54  // and ideal workspace size.
55  lwork = -1;
56  lrwork = -1;
57  liwork = -1;
58  FLA_Obj_create( datatype, 1, 1, 0, 0, &work );
59  FLA_Obj_create( dt_real, 1, 1, 0, 0, &rwork );
60  FLA_Obj_create( FLA_INT, 1, 1, 0, 0, &iwork );
61 
62  for ( i = 0; i < 2; ++i )
63  {
64  if ( i == 1 )
65  {
66  // Grab the queried ideal workspace size from the work arrays, free the
67  // work object, and then re-allocate the workspace with the ideal size.
68  if ( datatype == FLA_FLOAT || datatype == FLA_COMPLEX )
69  {
70  lwork = ( int ) *FLA_FLOAT_PTR( work );
71  lrwork = ( int ) *FLA_FLOAT_PTR( rwork );
72  liwork = ( int ) *FLA_INT_PTR( iwork );
73  }
74  else if ( datatype == FLA_DOUBLE || datatype == FLA_DOUBLE_COMPLEX )
75  {
76  lwork = ( int ) *FLA_DOUBLE_PTR( work );
77  lrwork = ( int ) *FLA_DOUBLE_PTR( rwork );
78  liwork = ( int ) *FLA_INT_PTR( iwork );
79  }
80 
81  FLA_Obj_free( &work );
82  FLA_Obj_free( &iwork );
83  FLA_Obj_free( &rwork );
84  FLA_Obj_create( datatype, lwork, 1, 0, 0, &work );
85  FLA_Obj_create( FLA_INT, liwork, 1, 0, 0, &iwork );
86  if ( FLA_Obj_is_complex( A ) )
87  FLA_Obj_create( dt_real, lrwork, 1, 0, 0, &rwork );
88  }
89 
90  switch( datatype ) {
91 
92  case FLA_FLOAT:
93  {
94  float* buff_A = ( float* ) FLA_FLOAT_PTR( A );
95  float* buff_l = ( float* ) FLA_FLOAT_PTR( l );
96  float* buff_Z = ( float* ) FLA_FLOAT_PTR( Z );
97  float* buff_work = ( float* ) FLA_FLOAT_PTR( work );
98  float* buff_abstol = ( float* ) FLA_FLOAT_PTR( abstol );
99  int* buff_iwork = ( int* ) FLA_INT_PTR( iwork );
100  int* buff_isuppz = ( int* ) FLA_INT_PTR( isuppz );
101  float vl, vu;
102 
103  F77_ssyevr( &blas_jobz,
104  &blas_range,
105  &blas_uplo,
106  &n_A,
107  buff_A, &cs_A,
108  &vl, &vu,
109  &il, &iu,
110  buff_abstol,
111  &eigs_found,
112  buff_l,
113  buff_Z, &cs_Z,
114  buff_isuppz,
115  buff_work, &lwork,
116  buff_iwork, &liwork,
117  &info );
118  break;
119  }
120 
121  case FLA_DOUBLE:
122  {
123  double* buff_A = ( double* ) FLA_DOUBLE_PTR( A );
124  double* buff_l = ( double* ) FLA_DOUBLE_PTR( l );
125  double* buff_Z = ( double* ) FLA_DOUBLE_PTR( Z );
126  double* buff_work = ( double* ) FLA_DOUBLE_PTR( work );
127  double* buff_abstol = ( double* ) FLA_DOUBLE_PTR( abstol );
128  int* buff_iwork = ( int* ) FLA_INT_PTR( iwork );
129  int* buff_isuppz = ( int* ) FLA_INT_PTR( isuppz );
130  double vl, vu;
131 
132  F77_dsyevr( &blas_jobz,
133  &blas_range,
134  &blas_uplo,
135  &n_A,
136  buff_A, &cs_A,
137  &vl, &vu,
138  &il, &iu,
139  buff_abstol,
140  &eigs_found,
141  buff_l,
142  buff_Z, &cs_Z,
143  buff_isuppz,
144  buff_work, &lwork,
145  buff_iwork, &liwork,
146  &info );
147  break;
148  }
149 
150  case FLA_COMPLEX:
151  {
152  scomplex* buff_A = ( scomplex* ) FLA_COMPLEX_PTR( A );
153  float* buff_l = ( float* ) FLA_FLOAT_PTR( l );
154  scomplex* buff_Z = ( scomplex* ) FLA_COMPLEX_PTR( Z );
155  scomplex* buff_work = ( scomplex* ) FLA_COMPLEX_PTR( work );
156  float* buff_rwork = ( float* ) FLA_FLOAT_PTR( rwork );
157  float* buff_abstol = ( float* ) FLA_FLOAT_PTR( abstol );
158  int* buff_iwork = ( int* ) FLA_INT_PTR( iwork );
159  int* buff_isuppz = ( int* ) FLA_INT_PTR( isuppz );
160  float vl, vu;
161 
162  F77_cheevr( &blas_jobz,
163  &blas_range,
164  &blas_uplo,
165  &n_A,
166  buff_A, &cs_A,
167  &vl, &vu,
168  &il, &iu,
169  buff_abstol,
170  &eigs_found,
171  buff_l,
172  buff_Z, &cs_Z,
173  buff_isuppz,
174  buff_work, &lwork,
175  buff_rwork, &lrwork,
176  buff_iwork, &liwork,
177  &info );
178  break;
179  }
180 
181  case FLA_DOUBLE_COMPLEX:
182  {
183  dcomplex* buff_A = ( dcomplex* ) FLA_DOUBLE_COMPLEX_PTR( A );
184  double* buff_l = ( double* ) FLA_DOUBLE_PTR( l );
185  dcomplex* buff_Z = ( dcomplex* ) FLA_DOUBLE_COMPLEX_PTR( Z );
186  dcomplex* buff_work = ( dcomplex* ) FLA_DOUBLE_COMPLEX_PTR( work );
187  double* buff_rwork = ( double* ) FLA_DOUBLE_PTR( rwork );
188  double* buff_abstol = ( double* ) FLA_DOUBLE_PTR( abstol );
189  int* buff_iwork = ( int* ) FLA_INT_PTR( iwork );
190  int* buff_isuppz = ( int* ) FLA_INT_PTR( isuppz );
191  double vl, vu;
192 
193  F77_zheevr( &blas_jobz,
194  &blas_range,
195  &blas_uplo,
196  &n_A,
197  buff_A, &cs_A,
198  &vl, &vu,
199  &il, &iu,
200  buff_abstol,
201  &eigs_found,
202  buff_l,
203  buff_Z, &cs_Z,
204  buff_isuppz,
205  buff_work, &lwork,
206  buff_rwork, &lrwork,
207  buff_iwork, &liwork,
208  &info );
209  break;
210  }
211 
212  }
213  }
214 
215  FLA_Obj_free( &work );
216  FLA_Obj_free( &iwork );
217  FLA_Obj_free( &isuppz );
218  FLA_Obj_free( &abstol );
219  if ( FLA_Obj_is_complex( A ) )
220  FLA_Obj_free( &rwork );
221 #else
222  FLA_Check_error_code( FLA_EXTERNAL_LAPACK_NOT_IMPLEMENTED );
223 #endif
224 
225  return info;
226 }
FLA_Error FLA_Hevdr_check(FLA_Evd_type jobz, FLA_Uplo uplo, FLA_Obj A, FLA_Obj l, FLA_Obj Z)
Definition: FLA_Hevdr_check.c:13
int F77_zheevr(char *jobz, char *range, char *uplo, int *n, dcomplex *a, int *lda, double *vl, double *vu, int *il, int *iu, double *abstol, int *m, double *w, dcomplex *z, int *ldz, int *isuppz, dcomplex *work, int *lwork, double *rwork, int *lrwork, int *iwork, int *liwork, int *info)
int F77_dsyevr(char *jobz, char *range, char *uplo, int *n, double *a, int *lda, double *vl, double *vu, int *il, int *iu, double *abstol, int *m, double *w, double *z, int *ldz, int *isuppz, double *work, int *lwork, int *iwork, int *liwork, int *info)
int F77_ssyevr(char *jobz, char *range, char *uplo, int *n, float *a, int *lda, float *vl, float *vu, int *il, int *iu, float *abstol, int *m, float *w, float *z, int *ldz, int *isuppz, float *work, int *lwork, int *iwork, int *liwork, int *info)
int F77_cheevr(char *jobz, char *range, char *uplo, int *n, scomplex *a, int *lda, float *vl, float *vu, int *il, int *iu, float *abstol, int *m, float *w, scomplex *z, int *ldz, int *isuppz, scomplex *work, int *lwork, float *rwork, int *lrwork, int *iwork, int *liwork, int *info)
void FLA_Param_map_flame_to_netlib_evd_type(FLA_Evd_type evd_type, void *lapack_evd_type)
Definition: FLA_Param.c:151
dim_t FLA_Obj_width(FLA_Obj obj)
Definition: FLA_Query.c:123
FLA_Error FLA_Obj_create(FLA_Datatype datatype, dim_t m, dim_t n, dim_t rs, dim_t cs, FLA_Obj *obj)
Definition: FLA_Obj.c:55
FLA_Bool FLA_Obj_has_zero_dim(FLA_Obj A)
Definition: FLA_Query.c:400
FLA_Datatype FLA_Obj_datatype_proj_to_real(FLA_Obj A)
Definition: FLA_Query.c:23
FLA_Bool FLA_Obj_is_complex(FLA_Obj A)
Definition: FLA_Query.c:324
dim_t FLA_Obj_col_stride(FLA_Obj obj)
Definition: FLA_Query.c:174
unsigned int FLA_Check_error_level(void)
Definition: FLA_Check.c:18
FLA_Error FLA_Obj_free(FLA_Obj *obj)
Definition: FLA_Obj.c:588
void FLA_Param_map_flame_to_netlib_uplo(FLA_Uplo uplo, void *blas_uplo)
Definition: FLA_Param.c:47
FLA_Datatype FLA_Obj_datatype(FLA_Obj obj)
Definition: FLA_Query.c:13
int FLA_Datatype
Definition: FLA_type_defs.h:49
FLA_Error FLA_Mach_params(FLA_Machval machval, FLA_Obj val)
Definition: FLA_Mach_params.c:13
int i
Definition: bl1_axmyv2.c:145
Definition: FLA_type_defs.h:159
Definition: blis_type_defs.h:138
Definition: blis_type_defs.h:133

References F77_cheevr(), F77_dsyevr(), F77_ssyevr(), F77_zheevr(), FLA_Check_error_level(), FLA_Hevdr_check(), FLA_Mach_params(), FLA_Obj_col_stride(), FLA_Obj_create(), FLA_Obj_datatype(), FLA_Obj_datatype_proj_to_real(), FLA_Obj_free(), FLA_Obj_has_zero_dim(), FLA_Obj_is_complex(), FLA_Obj_width(), FLA_Param_map_flame_to_netlib_evd_type(), FLA_Param_map_flame_to_netlib_uplo(), and i.