libflame  revision_anchor
Functions
FLA_QR_form_Q_external.c File Reference

(r)

Functions

FLA_Error FLA_QR_form_Q_external (FLA_Obj A, FLA_Obj t)
 

Function Documentation

◆ FLA_QR_form_Q_external()

FLA_Error FLA_QR_form_Q_external ( FLA_Obj  A,
FLA_Obj  t 
)

References F77_cungqr(), F77_dorgqr(), F77_sorgqr(), F77_zungqr(), FLA_Check_error_level(), FLA_Obj_col_stride(), FLA_Obj_create(), FLA_Obj_datatype(), FLA_Obj_free(), FLA_Obj_has_zero_dim(), FLA_Obj_length(), FLA_Obj_vector_dim(), FLA_Obj_width(), FLA_QR_form_Q_check(), and i.

14 {
15  int info = 0;
16 #ifdef FLA_ENABLE_EXTERNAL_LAPACK_INTERFACES
17  FLA_Datatype datatype;
18  int m_A, n_A, k_A;
19  int cs_A;
20  int lwork;
21  FLA_Obj work;
22  int i;
23 
24  if ( FLA_Check_error_level() == FLA_FULL_ERROR_CHECKING )
25  FLA_QR_form_Q_check( A, t );
26 
27  if ( FLA_Obj_has_zero_dim( A ) ) return FLA_SUCCESS;
28 
29  datatype = FLA_Obj_datatype( A );
30 
31  m_A = FLA_Obj_length( A );
32  n_A = FLA_Obj_width( A );
33  cs_A = FLA_Obj_col_stride( A );
34 
35  k_A = FLA_Obj_vector_dim( t );
36 
37  // Make a workspace query the first time through. This will provide us with
38  // and ideal workspace size based on an internal block size.
39  lwork = -1;
40  FLA_Obj_create( datatype, 1, 1, 0, 0, &work );
41 
42  for ( i = 0; i < 2; ++i )
43  {
44  if ( i == 1 )
45  {
46  // Grab the queried ideal workspace size from the work array, free the
47  // work object, and then re-allocate the workspace with the ideal size.
48  if ( datatype == FLA_FLOAT || datatype == FLA_COMPLEX )
49  lwork = ( int ) *FLA_FLOAT_PTR( work );
50  else if ( datatype == FLA_DOUBLE || datatype == FLA_DOUBLE_COMPLEX )
51  lwork = ( int ) *FLA_DOUBLE_PTR( work );
52 
53  FLA_Obj_free( &work );
54  FLA_Obj_create( datatype, lwork, 1, 0, 0, &work );
55  }
56 
57  switch( datatype ){
58 
59  case FLA_FLOAT:
60  {
61  float* buff_A = ( float * ) FLA_FLOAT_PTR( A );
62  float* buff_t = ( float * ) FLA_FLOAT_PTR( t );
63  float* buff_work = ( float * ) FLA_FLOAT_PTR( work );
64 
65  F77_sorgqr( &m_A,
66  &n_A,
67  &k_A,
68  buff_A, &cs_A,
69  buff_t,
70  buff_work, &lwork,
71  &info );
72 
73  break;
74  }
75 
76  case FLA_DOUBLE:
77  {
78  double* buff_A = ( double * ) FLA_DOUBLE_PTR( A );
79  double* buff_t = ( double * ) FLA_DOUBLE_PTR( t );
80  double* buff_work = ( double * ) FLA_DOUBLE_PTR( work );
81 
82  F77_dorgqr( &m_A,
83  &n_A,
84  &k_A,
85  buff_A, &cs_A,
86  buff_t,
87  buff_work, &lwork,
88  &info );
89 
90  break;
91  }
92 
93  case FLA_COMPLEX:
94  {
95  scomplex* buff_A = ( scomplex * ) FLA_COMPLEX_PTR( A );
96  scomplex* buff_t = ( scomplex * ) FLA_COMPLEX_PTR( t );
97  scomplex* buff_work = ( scomplex * ) FLA_COMPLEX_PTR( work );
98 
99  F77_cungqr( &m_A,
100  &n_A,
101  &k_A,
102  buff_A, &cs_A,
103  buff_t,
104  buff_work, &lwork,
105  &info );
106 
107  break;
108  }
109 
110  case FLA_DOUBLE_COMPLEX:
111  {
112  dcomplex *buff_A = ( dcomplex * ) FLA_DOUBLE_COMPLEX_PTR( A );
113  dcomplex *buff_t = ( dcomplex * ) FLA_DOUBLE_COMPLEX_PTR( t );
114  dcomplex *buff_work = ( dcomplex * ) FLA_DOUBLE_COMPLEX_PTR( work );
115 
116  F77_zungqr( &m_A,
117  &n_A,
118  &k_A,
119  buff_A, &cs_A,
120  buff_t,
121  buff_work, &lwork,
122  &info );
123 
124  break;
125  }
126 
127  }
128 
129  }
130 
131  FLA_Obj_free( &work );
132 #else
133  FLA_Check_error_code( FLA_EXTERNAL_LAPACK_NOT_IMPLEMENTED );
134 #endif
135 
136  return info;
137 }
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_Error FLA_Obj_free(FLA_Obj *obj)
Definition: FLA_Obj.c:588
FLA_Error FLA_QR_form_Q_check(FLA_Obj A, FLA_Obj t)
Definition: FLA_QR_form_Q_check.c:13
int F77_sorgqr(int *m, int *n, int *k, float *a, int *lda, float *tau, float *work, int *lwork, int *info)
FLA_Datatype FLA_Obj_datatype(FLA_Obj obj)
Definition: FLA_Query.c:13
Definition: FLA_type_defs.h:158
FLA_Bool FLA_Obj_has_zero_dim(FLA_Obj A)
Definition: FLA_Query.c:400
dim_t FLA_Obj_width(FLA_Obj obj)
Definition: FLA_Query.c:123
int F77_dorgqr(int *m, int *n, int *k, double *a, int *lda, double *tau, double *work, int *lwork, int *info)
int F77_cungqr(int *m, int *n, int *k, scomplex *a, int *lda, scomplex *tau, scomplex *work, int *lwork, int *info)
Definition: blis_type_defs.h:132
dim_t FLA_Obj_vector_dim(FLA_Obj obj)
Definition: FLA_Query.c:137
unsigned int FLA_Check_error_level(void)
Definition: FLA_Check.c:18
int FLA_Datatype
Definition: FLA_type_defs.h:49
int F77_zungqr(int *m, int *n, int *k, dcomplex *a, int *lda, dcomplex *tau, dcomplex *work, int *lwork, int *info)
dim_t FLA_Obj_col_stride(FLA_Obj obj)
Definition: FLA_Query.c:174
int i
Definition: bl1_axmyv2.c:145
dim_t FLA_Obj_length(FLA_Obj obj)
Definition: FLA_Query.c:116
Definition: blis_type_defs.h:137