libflame  revision_anchor
Functions
FLA_Bidiag_apply_U_external.c File Reference

(r)

Functions

FLA_Error FLA_Bidiag_apply_U_external (FLA_Side side, FLA_Trans trans, FLA_Obj A, FLA_Obj t, FLA_Obj B)
 

Function Documentation

◆ FLA_Bidiag_apply_U_external()

FLA_Error FLA_Bidiag_apply_U_external ( FLA_Side  side,
FLA_Trans  trans,
FLA_Obj  A,
FLA_Obj  t,
FLA_Obj  B 
)

References F77_cunmbr(), F77_dormbr(), F77_sormbr(), F77_zunmbr(), FLA_Obj_col_stride(), FLA_Obj_create(), FLA_Obj_datatype(), FLA_Obj_free(), FLA_Obj_has_zero_dim(), FLA_Obj_is_real(), FLA_Obj_length(), FLA_Obj_vector_dim(), FLA_Obj_width(), FLA_Param_map_flame_to_netlib_side(), FLA_Param_map_flame_to_netlib_trans(), and i.

14 {
15  int info = 0;
16 #ifdef FLA_ENABLE_EXTERNAL_LAPACK_INTERFACES
17  FLA_Datatype datatype;
18  // int m_A, n_A;
19  int m_B, n_B;
20  int cs_A;
21  int cs_B;
22  int k_t;
23  int lwork;
24  FLA_Obj work;
25  char blas_side;
26  char blas_vect = 'Q';
27  char blas_trans;
28  int i;
29 
30  //if ( FLA_Check_error_level() == FLA_FULL_ERROR_CHECKING )
31  // FLA_Apply_Q_check( side, trans, storev, A, t, B );
32 
33  if ( FLA_Obj_has_zero_dim( A ) ) return FLA_SUCCESS;
34 
35  datatype = FLA_Obj_datatype( A );
36 
37  // m_A = FLA_Obj_length( A );
38  // n_A = FLA_Obj_width( A );
39  cs_A = FLA_Obj_col_stride( A );
40 
41  m_B = FLA_Obj_length( B );
42  n_B = FLA_Obj_width( B );
43  cs_B = FLA_Obj_col_stride( B );
44 
45  if ( blas_vect == 'Q' ) k_t = FLA_Obj_vector_dim( t );
46  else k_t = FLA_Obj_vector_dim( t ) + 1;
47 
48  if ( FLA_Obj_is_real( A ) && trans == FLA_CONJ_TRANSPOSE )
49  trans = FLA_TRANSPOSE;
50 
51  FLA_Param_map_flame_to_netlib_side( side, &blas_side );
52  FLA_Param_map_flame_to_netlib_trans( trans, &blas_trans );
53 
54 
55  // Make a workspace query the first time through. This will provide us with
56  // and ideal workspace size based on an internal block size.
57  lwork = -1;
58  FLA_Obj_create( datatype, 1, 1, 0, 0, &work );
59 
60  for ( i = 0; i < 2; ++i )
61  {
62  if ( i == 1 )
63  {
64  // Grab the queried ideal workspace size from the work array, free the
65  // work object, and then re-allocate the workspace with the ideal size.
66  if ( datatype == FLA_FLOAT || datatype == FLA_COMPLEX )
67  lwork = ( int ) *FLA_FLOAT_PTR( work );
68  else if ( datatype == FLA_DOUBLE || datatype == FLA_DOUBLE_COMPLEX )
69  lwork = ( int ) *FLA_DOUBLE_PTR( work );
70 
71  FLA_Obj_free( &work );
72  FLA_Obj_create( datatype, lwork, 1, 0, 0, &work );
73  }
74 
75  switch( datatype ){
76 
77  case FLA_FLOAT:
78  {
79  float *buff_A = ( float * ) FLA_FLOAT_PTR( A );
80  float *buff_t = ( float * ) FLA_FLOAT_PTR( t );
81  float *buff_B = ( float * ) FLA_FLOAT_PTR( B );
82  float *buff_work = ( float * ) FLA_FLOAT_PTR( work );
83 
84  F77_sormbr( &blas_vect,
85  &blas_side,
86  &blas_trans,
87  &m_B,
88  &n_B,
89  &k_t,
90  buff_A, &cs_A,
91  buff_t,
92  buff_B, &cs_B,
93  buff_work, &lwork,
94  &info );
95 
96  break;
97  }
98 
99  case FLA_DOUBLE:
100  {
101  double *buff_A = ( double * ) FLA_DOUBLE_PTR( A );
102  double *buff_t = ( double * ) FLA_DOUBLE_PTR( t );
103  double *buff_B = ( double * ) FLA_DOUBLE_PTR( B );
104  double *buff_work = ( double * ) FLA_DOUBLE_PTR( work );
105 
106  F77_dormbr( &blas_vect,
107  &blas_side,
108  &blas_trans,
109  &m_B,
110  &n_B,
111  &k_t,
112  buff_A, &cs_A,
113  buff_t,
114  buff_B, &cs_B,
115  buff_work, &lwork,
116  &info );
117 
118  break;
119  }
120 
121  case FLA_COMPLEX:
122  {
123  scomplex *buff_A = ( scomplex * ) FLA_COMPLEX_PTR( A );
124  scomplex *buff_t = ( scomplex * ) FLA_COMPLEX_PTR( t );
125  scomplex *buff_B = ( scomplex * ) FLA_COMPLEX_PTR( B );
126  scomplex *buff_work = ( scomplex * ) FLA_COMPLEX_PTR( work );
127 
128  F77_cunmbr( &blas_vect,
129  &blas_side,
130  &blas_trans,
131  &m_B,
132  &n_B,
133  &k_t,
134  buff_A, &cs_A,
135  buff_t,
136  buff_B, &cs_B,
137  buff_work, &lwork,
138  &info );
139 
140  break;
141  }
142 
143  case FLA_DOUBLE_COMPLEX:
144  {
145  dcomplex *buff_A = ( dcomplex * ) FLA_DOUBLE_COMPLEX_PTR( A );
146  dcomplex *buff_t = ( dcomplex * ) FLA_DOUBLE_COMPLEX_PTR( t );
147  dcomplex *buff_B = ( dcomplex * ) FLA_DOUBLE_COMPLEX_PTR( B );
148  dcomplex *buff_work = ( dcomplex * ) FLA_DOUBLE_COMPLEX_PTR( work );
149 
150  F77_zunmbr( &blas_vect,
151  &blas_side,
152  &blas_trans,
153  &m_B,
154  &n_B,
155  &k_t,
156  buff_A, &cs_A,
157  buff_t,
158  buff_B, &cs_B,
159  buff_work, &lwork,
160  &info );
161 
162  break;
163  }
164 
165  }
166  }
167 
168  FLA_Obj_free( &work );
169 #else
170  FLA_Check_error_code( FLA_EXTERNAL_LAPACK_NOT_IMPLEMENTED );
171 #endif
172 
173  return info;
174 }
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
void FLA_Param_map_flame_to_netlib_side(FLA_Uplo side, void *blas_side)
Definition: FLA_Param.c:71
void FLA_Param_map_flame_to_netlib_trans(FLA_Trans trans, void *blas_trans)
Definition: FLA_Param.c:15
int F77_zunmbr(char *vect, char *side, char *trans, int *m, int *n, int *k, dcomplex *a, int *lda, dcomplex *tau, dcomplex *c, int *ldc, dcomplex *work, int *lwork, int *info)
int F77_dormbr(char *vect, char *side, char *trans, int *m, int *n, int *k, double *a, int *lda, double *tau, double *c, int *ldc, double *work, int *lwork, int *info)
int F77_cunmbr(char *vect, char *side, char *trans, int *m, int *n, int *k, scomplex *a, int *lda, scomplex *tau, scomplex *c, int *ldc, scomplex *work, int *lwork, int *info)
int F77_sormbr(char *vect, char *side, char *trans, int *m, int *n, int *k, float *a, int *lda, float *tau, float *c, int *ldc, 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
Definition: blis_type_defs.h:132
dim_t FLA_Obj_vector_dim(FLA_Obj obj)
Definition: FLA_Query.c:137
int FLA_Datatype
Definition: FLA_type_defs.h:49
dim_t FLA_Obj_col_stride(FLA_Obj obj)
Definition: FLA_Query.c:174
int i
Definition: bl1_axmyv2.c:145
FLA_Bool FLA_Obj_is_real(FLA_Obj A)
Definition: FLA_Query.c:307
dim_t FLA_Obj_length(FLA_Obj obj)
Definition: FLA_Query.c:116
Definition: blis_type_defs.h:137