libflame  revision_anchor
Functions
FLA_Hevd_external.c File Reference

(r)

Functions

FLA_Error FLA_Hevd_external (FLA_Evd_type jobz, FLA_Uplo uplo, FLA_Obj A, FLA_Obj e)
 

Function Documentation

◆ FLA_Hevd_external()

FLA_Error FLA_Hevd_external ( FLA_Evd_type  jobz,
FLA_Uplo  uplo,
FLA_Obj  A,
FLA_Obj  e 
)
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 lwork, lrwork;
21  FLA_Obj work, rwork;
22  char blas_jobz;
23  char blas_uplo;
24  int i;
25 
26  if ( FLA_Check_error_level() == FLA_FULL_ERROR_CHECKING )
27  FLA_Hevd_check( jobz, uplo, A, e );
28 
29  if ( FLA_Obj_has_zero_dim( A ) ) return FLA_SUCCESS;
30 
31  datatype = FLA_Obj_datatype( A );
32  dt_real = FLA_Obj_datatype_proj_to_real( A );
33 
34  n_A = FLA_Obj_width( A );
35  cs_A = FLA_Obj_col_stride( A );
36 
37  // Allocate the rwork array up front since its size is not dependent on
38  // internal block sizes.
39  lrwork = max( 1, 3 * n_A - 2 );
40  FLA_Obj_create( dt_real, lrwork, 1, 0, 0, &rwork );
41 
42  FLA_Param_map_flame_to_netlib_evd_type( jobz, &blas_jobz );
43  FLA_Param_map_flame_to_netlib_uplo( uplo, &blas_uplo );
44 
45  // Make a workspace query the first time through. This will provide us with
46  // and ideal workspace size based on an internal block size.
47  lwork = -1;
48  FLA_Obj_create( datatype, 1, 1, 0, 0, &work );
49 
50  for ( i = 0; i < 2; ++i )
51  {
52  if ( i == 1 )
53  {
54  // Grab the queried ideal workspace size from the work array, free the
55  // work object, and then re-allocate the workspace with the ideal size.
56  if ( datatype == FLA_FLOAT || datatype == FLA_COMPLEX )
57  lwork = ( int ) *FLA_FLOAT_PTR( work );
58  else if ( datatype == FLA_DOUBLE || datatype == FLA_DOUBLE_COMPLEX )
59  lwork = ( int ) *FLA_DOUBLE_PTR( work );
60 
61  FLA_Obj_free( &work );
62  FLA_Obj_create( datatype, lwork, 1, 0, 0, &work );
63  }
64 
65  switch( datatype ) {
66 
67  case FLA_FLOAT:
68  {
69  float* buff_A = ( float * ) FLA_FLOAT_PTR( A );
70  float* buff_e = ( float * ) FLA_FLOAT_PTR( e );
71  float* buff_work = ( float * ) FLA_FLOAT_PTR( work );
72  float* buff_rwork = ( float * ) FLA_FLOAT_PTR( rwork );
73 
74  F77_ssyev( &blas_jobz,
75  &blas_uplo,
76  &n_A,
77  buff_A, &cs_A,
78  buff_e,
79  buff_work, &lwork,
80  buff_rwork,
81  &info );
82 
83  break;
84  }
85 
86  case FLA_DOUBLE:
87  {
88  double* buff_A = ( double * ) FLA_DOUBLE_PTR( A );
89  double* buff_e = ( double * ) FLA_DOUBLE_PTR( e );
90  double* buff_work = ( double * ) FLA_DOUBLE_PTR( work );
91  double* buff_rwork = ( double * ) FLA_DOUBLE_PTR( rwork );
92 
93  F77_dsyev( &blas_jobz,
94  &blas_uplo,
95  &n_A,
96  buff_A, &cs_A,
97  buff_e,
98  buff_work, &lwork,
99  buff_rwork,
100  &info );
101 
102  break;
103  }
104 
105  case FLA_COMPLEX:
106  {
107  scomplex* buff_A = ( scomplex * ) FLA_COMPLEX_PTR( A );
108  float* buff_e = ( float * ) FLA_FLOAT_PTR( e );
109  scomplex* buff_work = ( scomplex * ) FLA_COMPLEX_PTR( work );
110  float* buff_rwork = ( float * ) FLA_FLOAT_PTR( rwork );
111 
112  F77_cheev( &blas_jobz,
113  &blas_uplo,
114  &n_A,
115  buff_A, &cs_A,
116  buff_e,
117  buff_work, &lwork,
118  buff_rwork,
119  &info );
120 
121  break;
122  }
123 
124  case FLA_DOUBLE_COMPLEX:
125  {
126  dcomplex* buff_A = ( dcomplex* ) FLA_DOUBLE_COMPLEX_PTR( A );
127  double* buff_e = ( double* ) FLA_DOUBLE_PTR( e );
128  dcomplex* buff_work = ( dcomplex* ) FLA_DOUBLE_COMPLEX_PTR( work );
129  double* buff_rwork = ( double* ) FLA_DOUBLE_PTR( rwork );
130 
131  F77_zheev( &blas_jobz,
132  &blas_uplo,
133  &n_A,
134  buff_A, &cs_A,
135  buff_e,
136  buff_work, &lwork,
137  buff_rwork,
138  &info );
139 
140  break;
141  }
142 
143  }
144  }
145 
146  FLA_Obj_free( &work );
147  FLA_Obj_free( &rwork );
148 #else
149  FLA_Check_error_code( FLA_EXTERNAL_LAPACK_NOT_IMPLEMENTED );
150 #endif
151 
152  return info;
153 }
FLA_Error FLA_Hevd_check(FLA_Evd_type jobz, FLA_Uplo uplo, FLA_Obj A, FLA_Obj e)
Definition: FLA_Hevd_check.c:13
int F77_zheev(char *jobz, char *uplo, int *n, dcomplex *a, int *lda, double *w, dcomplex *work, int *lwork, double *rwork, int *info)
int F77_cheev(char *jobz, char *uplo, int *n, scomplex *a, int *lda, float *w, scomplex *work, int *lwork, float *rwork, int *info)
int F77_dsyev(char *jobz, char *uplo, int *n, double *a, int *lda, double *w, double *work, int *lwork, double *rwork, int *info)
int F77_ssyev(char *jobz, char *uplo, int *n, float *a, int *lda, float *w, float *work, int *lwork, float *rwork, 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
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
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_cheev(), F77_dsyev(), F77_ssyev(), F77_zheev(), FLA_Check_error_level(), FLA_Hevd_check(), 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_width(), FLA_Param_map_flame_to_netlib_evd_type(), FLA_Param_map_flame_to_netlib_uplo(), and i.