int f2c_chemm(char* side, char* uplo, integer* M, integer* N, complex* alpha, complex* A, integer* lda, complex* B, integer* ldb, complex* beta, complex* C, integer* ldc) { chemm_(side, uplo, M, N, alpha, A, lda, B, ldb, beta, C, ldc); return 0; }
void chemm(char side, char uplo, int m, int n, complex *alpha, complex *a, int lda, complex *b, int ldb, complex *beta, complex *c, int ldc) { chemm_( &side, &uplo, &m, &n, alpha, a, &lda, b, &ldb, beta, c, &ldc); }
int main( int argc, char** argv ) { obj_t a, b, c; obj_t c_save; obj_t alpha, beta; dim_t m, n; dim_t p; dim_t p_begin, p_end, p_inc; int m_input, n_input; num_t dt; int r, n_repeats; side_t side; uplo_t uploa; f77_char f77_side; f77_char f77_uploa; double dtime; double dtime_save; double gflops; bli_init(); //bli_error_checking_level_set( BLIS_NO_ERROR_CHECKING ); n_repeats = 3; #ifndef PRINT p_begin = 200; p_end = 2000; p_inc = 200; m_input = -1; n_input = -1; #else p_begin = 16; p_end = 16; p_inc = 1; m_input = 4; n_input = 4; #endif #if 1 //dt = BLIS_FLOAT; dt = BLIS_DOUBLE; #else //dt = BLIS_SCOMPLEX; dt = BLIS_DCOMPLEX; #endif side = BLIS_LEFT; //side = BLIS_RIGHT; uploa = BLIS_LOWER; //uploa = BLIS_UPPER; bli_param_map_blis_to_netlib_side( side, &f77_side ); bli_param_map_blis_to_netlib_uplo( uploa, &f77_uploa ); for ( p = p_begin; p <= p_end; p += p_inc ) { if ( m_input < 0 ) m = p * ( dim_t )abs(m_input); else m = ( dim_t ) m_input; if ( n_input < 0 ) n = p * ( dim_t )abs(n_input); else n = ( dim_t ) n_input; bli_obj_create( dt, 1, 1, 0, 0, &alpha ); bli_obj_create( dt, 1, 1, 0, 0, &beta ); if ( bli_is_left( side ) ) bli_obj_create( dt, m, m, 0, 0, &a ); else bli_obj_create( dt, n, n, 0, 0, &a ); bli_obj_create( dt, m, n, 0, 0, &b ); bli_obj_create( dt, m, n, 0, 0, &c ); bli_obj_create( dt, m, n, 0, 0, &c_save ); bli_randm( &a ); bli_randm( &b ); bli_randm( &c ); bli_obj_set_struc( BLIS_HERMITIAN, a ); bli_obj_set_uplo( uploa, a ); // Randomize A, make it densely Hermitian, and zero the unstored // triangle to ensure the implementation reads only from the stored // region. bli_randm( &a ); bli_mkherm( &a ); bli_mktrim( &a ); /* bli_obj_toggle_uplo( a ); bli_obj_inc_diag_off( 1, a ); bli_setm( &BLIS_ZERO, &a ); bli_obj_inc_diag_off( -1, a ); bli_obj_toggle_uplo( a ); bli_obj_set_diag( BLIS_NONUNIT_DIAG, a ); bli_scalm( &BLIS_TWO, &a ); bli_scalm( &BLIS_TWO, &a ); */ bli_setsc( (2.0/1.0), 1.0, &alpha ); bli_setsc( -(1.0/1.0), 0.0, &beta ); bli_copym( &c, &c_save ); dtime_save = 1.0e9; for ( r = 0; r < n_repeats; ++r ) { bli_copym( &c_save, &c ); dtime = bli_clock(); #ifdef PRINT bli_printm( "a", &a, "%4.1f", "" ); bli_printm( "b", &b, "%4.1f", "" ); bli_printm( "c", &c, "%4.1f", "" ); #endif #ifdef BLIS bli_hemm( side, &alpha, &a, &b, &beta, &c ); #else if ( bli_is_float( dt ) ) { f77_int mm = bli_obj_length( c ); f77_int nn = bli_obj_width( c ); f77_int lda = bli_obj_col_stride( a ); f77_int ldb = bli_obj_col_stride( b ); f77_int ldc = bli_obj_col_stride( c ); float* alphap = bli_obj_buffer( alpha ); float* ap = bli_obj_buffer( a ); float* bp = bli_obj_buffer( b ); float* betap = bli_obj_buffer( beta ); float* cp = bli_obj_buffer( c ); ssymm_( &f77_side, &f77_uploa, &mm, &nn, alphap, ap, &lda, bp, &ldb, betap, cp, &ldc ); } else if ( bli_is_double( dt ) ) { f77_int mm = bli_obj_length( c ); f77_int nn = bli_obj_width( c ); f77_int lda = bli_obj_col_stride( a ); f77_int ldb = bli_obj_col_stride( b ); f77_int ldc = bli_obj_col_stride( c ); double* alphap = bli_obj_buffer( alpha ); double* ap = bli_obj_buffer( a ); double* bp = bli_obj_buffer( b ); double* betap = bli_obj_buffer( beta ); double* cp = bli_obj_buffer( c ); dsymm_( &f77_side, &f77_uploa, &mm, &nn, alphap, ap, &lda, bp, &ldb, betap, cp, &ldc ); } else if ( bli_is_scomplex( dt ) ) { f77_int mm = bli_obj_length( c ); f77_int nn = bli_obj_width( c ); f77_int lda = bli_obj_col_stride( a ); f77_int ldb = bli_obj_col_stride( b ); f77_int ldc = bli_obj_col_stride( c ); scomplex* alphap = bli_obj_buffer( alpha ); scomplex* ap = bli_obj_buffer( a ); scomplex* bp = bli_obj_buffer( b ); scomplex* betap = bli_obj_buffer( beta ); scomplex* cp = bli_obj_buffer( c ); chemm_( &f77_side, &f77_uploa, &mm, &nn, alphap, ap, &lda, bp, &ldb, betap, cp, &ldc ); } else if ( bli_is_dcomplex( dt ) ) { f77_int mm = bli_obj_length( c ); f77_int nn = bli_obj_width( c ); f77_int lda = bli_obj_col_stride( a ); f77_int ldb = bli_obj_col_stride( b ); f77_int ldc = bli_obj_col_stride( c ); dcomplex* alphap = bli_obj_buffer( alpha ); dcomplex* ap = bli_obj_buffer( a ); dcomplex* bp = bli_obj_buffer( b ); dcomplex* betap = bli_obj_buffer( beta ); dcomplex* cp = bli_obj_buffer( c ); zhemm_( &f77_side, &f77_uploa, &mm, &nn, alphap, ap, &lda, bp, &ldb, betap, cp, &ldc ); } #endif #ifdef PRINT bli_printm( "c after", &c, "%9.5f", "" ); exit(1); #endif dtime_save = bli_clock_min_diff( dtime_save, dtime ); } if ( bli_is_left( side ) ) gflops = ( 2.0 * m * m * n ) / ( dtime_save * 1.0e9 ); else gflops = ( 2.0 * m * n * n ) / ( dtime_save * 1.0e9 ); if ( bli_is_complex( dt ) ) gflops *= 4.0; #ifdef BLIS printf( "data_hemm_blis" ); #else printf( "data_hemm_%s", BLAS ); #endif printf( "( %2lu, 1:4 ) = [ %4lu %4lu %10.3e %6.3f ];\n", ( unsigned long )(p - p_begin + 1)/p_inc + 1, ( unsigned long )m, ( unsigned long )n, dtime_save, gflops ); bli_obj_free( &alpha ); bli_obj_free( &beta ); bli_obj_free( &a ); bli_obj_free( &b ); bli_obj_free( &c ); bli_obj_free( &c_save ); } bli_finalize(); return 0; }
/* Subroutine */ int chegst_(integer *itype, char *uplo, integer *n, complex * a, integer *lda, complex *b, integer *ldb, integer *info) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3; complex q__1; /* Local variables */ integer k, kb, nb; extern /* Subroutine */ int chemm_(char *, char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *); extern logical lsame_(char *, char *); extern /* Subroutine */ int ctrmm_(char *, char *, char *, char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *), ctrsm_(char *, char *, char *, char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *); logical upper; extern /* Subroutine */ int chegs2_(integer *, char *, integer *, complex *, integer *, complex *, integer *, integer *), cher2k_( char *, char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, real *, complex *, integer *), xerbla_(char *, integer *); extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *); /* -- LAPACK routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CHEGST reduces a complex Hermitian-definite generalized */ /* eigenproblem to standard form. */ /* If ITYPE = 1, the problem is A*x = lambda*B*x, */ /* and A is overwritten by inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H) */ /* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or */ /* B*A*x = lambda*x, and A is overwritten by U*A*U**H or L**H*A*L. */ /* B must have been previously factorized as U**H*U or L*L**H by CPOTRF. */ /* Arguments */ /* ========= */ /* ITYPE (input) INTEGER */ /* = 1: compute inv(U**H)*A*inv(U) or inv(L)*A*inv(L**H); */ /* = 2 or 3: compute U*A*U**H or L**H*A*L. */ /* UPLO (input) CHARACTER*1 */ /* = 'U': Upper triangle of A is stored and B is factored as */ /* U**H*U; */ /* = 'L': Lower triangle of A is stored and B is factored as */ /* L*L**H. */ /* N (input) INTEGER */ /* The order of the matrices A and B. N >= 0. */ /* A (input/output) COMPLEX array, dimension (LDA,N) */ /* On entry, the Hermitian matrix A. If UPLO = 'U', the leading */ /* N-by-N upper triangular part of A contains the upper */ /* triangular part of the matrix A, and the strictly lower */ /* triangular part of A is not referenced. If UPLO = 'L', the */ /* leading N-by-N lower triangular part of A contains the lower */ /* triangular part of the matrix A, and the strictly upper */ /* triangular part of A is not referenced. */ /* On exit, if INFO = 0, the transformed matrix, stored in the */ /* same format as A. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. LDA >= max(1,N). */ /* B (input) COMPLEX array, dimension (LDB,N) */ /* The triangular factor from the Cholesky factorization of B, */ /* as returned by CPOTRF. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. LDB >= max(1,N). */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (*itype < 1 || *itype > 3) { *info = -1; } else if (! upper && ! lsame_(uplo, "L")) { *info = -2; } else if (*n < 0) { *info = -3; } else if (*lda < max(1,*n)) { *info = -5; } else if (*ldb < max(1,*n)) { *info = -7; } if (*info != 0) { i__1 = -(*info); xerbla_("CHEGST", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } /* Determine the block size for this environment. */ nb = ilaenv_(&c__1, "CHEGST", uplo, n, &c_n1, &c_n1, &c_n1); if (nb <= 1 || nb >= *n) { /* Use unblocked code */ chegs2_(itype, uplo, n, &a[a_offset], lda, &b[b_offset], ldb, info); } else { /* Use blocked code */ if (*itype == 1) { if (upper) { /* Compute inv(U')*A*inv(U) */ i__1 = *n; i__2 = nb; for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) { /* Computing MIN */ i__3 = *n - k + 1; kb = min(i__3,nb); /* Update the upper triangle of A(k:n,k:n) */ chegs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + k * b_dim1], ldb, info); if (k + kb <= *n) { i__3 = *n - k - kb + 1; ctrsm_("Left", uplo, "Conjugate transpose", "Non-unit" , &kb, &i__3, &c_b1, &b[k + k * b_dim1], ldb, &a[k + (k + kb) * a_dim1], lda); i__3 = *n - k - kb + 1; q__1.r = -.5f, q__1.i = -0.f; chemm_("Left", uplo, &kb, &i__3, &q__1, &a[k + k * a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb, &c_b1, &a[k + (k + kb) * a_dim1], lda); i__3 = *n - k - kb + 1; q__1.r = -1.f, q__1.i = -0.f; cher2k_(uplo, "Conjugate transpose", &i__3, &kb, & q__1, &a[k + (k + kb) * a_dim1], lda, &b[k + ( k + kb) * b_dim1], ldb, &c_b18, &a[k + kb + ( k + kb) * a_dim1], lda) ; i__3 = *n - k - kb + 1; q__1.r = -.5f, q__1.i = -0.f; chemm_("Left", uplo, &kb, &i__3, &q__1, &a[k + k * a_dim1], lda, &b[k + (k + kb) * b_dim1], ldb, &c_b1, &a[k + (k + kb) * a_dim1], lda); i__3 = *n - k - kb + 1; ctrsm_("Right", uplo, "No transpose", "Non-unit", &kb, &i__3, &c_b1, &b[k + kb + (k + kb) * b_dim1], ldb, &a[k + (k + kb) * a_dim1], lda); } /* L10: */ } } else { /* Compute inv(L)*A*inv(L') */ i__2 = *n; i__1 = nb; for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) { /* Computing MIN */ i__3 = *n - k + 1; kb = min(i__3,nb); /* Update the lower triangle of A(k:n,k:n) */ chegs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + k * b_dim1], ldb, info); if (k + kb <= *n) { i__3 = *n - k - kb + 1; ctrsm_("Right", uplo, "Conjugate transpose", "Non-un" "it", &i__3, &kb, &c_b1, &b[k + k * b_dim1], ldb, &a[k + kb + k * a_dim1], lda); i__3 = *n - k - kb + 1; q__1.r = -.5f, q__1.i = -0.f; chemm_("Right", uplo, &i__3, &kb, &q__1, &a[k + k * a_dim1], lda, &b[k + kb + k * b_dim1], ldb, & c_b1, &a[k + kb + k * a_dim1], lda); i__3 = *n - k - kb + 1; q__1.r = -1.f, q__1.i = -0.f; cher2k_(uplo, "No transpose", &i__3, &kb, &q__1, &a[k + kb + k * a_dim1], lda, &b[k + kb + k * b_dim1], ldb, &c_b18, &a[k + kb + (k + kb) * a_dim1], lda); i__3 = *n - k - kb + 1; q__1.r = -.5f, q__1.i = -0.f; chemm_("Right", uplo, &i__3, &kb, &q__1, &a[k + k * a_dim1], lda, &b[k + kb + k * b_dim1], ldb, & c_b1, &a[k + kb + k * a_dim1], lda); i__3 = *n - k - kb + 1; ctrsm_("Left", uplo, "No transpose", "Non-unit", & i__3, &kb, &c_b1, &b[k + kb + (k + kb) * b_dim1], ldb, &a[k + kb + k * a_dim1], lda); } /* L20: */ } } } else { if (upper) { /* Compute U*A*U' */ i__1 = *n; i__2 = nb; for (k = 1; i__2 < 0 ? k >= i__1 : k <= i__1; k += i__2) { /* Computing MIN */ i__3 = *n - k + 1; kb = min(i__3,nb); /* Update the upper triangle of A(1:k+kb-1,1:k+kb-1) */ i__3 = k - 1; ctrmm_("Left", uplo, "No transpose", "Non-unit", &i__3, & kb, &c_b1, &b[b_offset], ldb, &a[k * a_dim1 + 1], lda); i__3 = k - 1; chemm_("Right", uplo, &i__3, &kb, &c_b2, &a[k + k * a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b1, &a[ k * a_dim1 + 1], lda); i__3 = k - 1; cher2k_(uplo, "No transpose", &i__3, &kb, &c_b1, &a[k * a_dim1 + 1], lda, &b[k * b_dim1 + 1], ldb, &c_b18, &a[a_offset], lda); i__3 = k - 1; chemm_("Right", uplo, &i__3, &kb, &c_b2, &a[k + k * a_dim1], lda, &b[k * b_dim1 + 1], ldb, &c_b1, &a[ k * a_dim1 + 1], lda); i__3 = k - 1; ctrmm_("Right", uplo, "Conjugate transpose", "Non-unit", & i__3, &kb, &c_b1, &b[k + k * b_dim1], ldb, &a[k * a_dim1 + 1], lda); chegs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + k * b_dim1], ldb, info); /* L30: */ } } else { /* Compute L'*A*L */ i__2 = *n; i__1 = nb; for (k = 1; i__1 < 0 ? k >= i__2 : k <= i__2; k += i__1) { /* Computing MIN */ i__3 = *n - k + 1; kb = min(i__3,nb); /* Update the lower triangle of A(1:k+kb-1,1:k+kb-1) */ i__3 = k - 1; ctrmm_("Right", uplo, "No transpose", "Non-unit", &kb, & i__3, &c_b1, &b[b_offset], ldb, &a[k + a_dim1], lda); i__3 = k - 1; chemm_("Left", uplo, &kb, &i__3, &c_b2, &a[k + k * a_dim1] , lda, &b[k + b_dim1], ldb, &c_b1, &a[k + a_dim1], lda); i__3 = k - 1; cher2k_(uplo, "Conjugate transpose", &i__3, &kb, &c_b1, & a[k + a_dim1], lda, &b[k + b_dim1], ldb, &c_b18, & a[a_offset], lda); i__3 = k - 1; chemm_("Left", uplo, &kb, &i__3, &c_b2, &a[k + k * a_dim1] , lda, &b[k + b_dim1], ldb, &c_b1, &a[k + a_dim1], lda); i__3 = k - 1; ctrmm_("Left", uplo, "Conjugate transpose", "Non-unit", & kb, &i__3, &c_b1, &b[k + k * b_dim1], ldb, &a[k + a_dim1], lda); chegs2_(itype, uplo, &kb, &a[k + k * a_dim1], lda, &b[k + k * b_dim1], ldb, info); /* L40: */ } } } } return 0; /* End of CHEGST */ } /* chegst_ */
/* Subroutine */ int chet22_(integer *itype, char *uplo, integer *n, integer * m, integer *kband, complex *a, integer *lda, real *d__, real *e, complex *u, integer *ldu, complex *v, integer *ldv, complex *tau, complex *work, real *rwork, real *result) { /* System generated locals */ integer a_dim1, a_offset, u_dim1, u_offset, v_dim1, v_offset, i__1, i__2, i__3, i__4; real r__1, r__2; complex q__1; /* Local variables */ integer j, jj, nn, jj1, jj2; real ulp; integer nnp1; real unfl; extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *), chemm_(char *, char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *), cunt01_(char *, integer *, integer *, complex *, integer *, complex *, integer *, real *, real *); real anorm, wnorm; extern doublereal clanhe_(char *, char *, integer *, complex *, integer *, real *), slamch_(char *); /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CHET22 generally checks a decomposition of the form */ /* A U = U S */ /* where A is complex Hermitian, the columns of U are orthonormal, */ /* and S is diagonal (if KBAND=0) or symmetric tridiagonal (if */ /* KBAND=1). If ITYPE=1, then U is represented as a dense matrix, */ /* otherwise the U is expressed as a product of Householder */ /* transformations, whose vectors are stored in the array "V" and */ /* whose scaling constants are in "TAU"; we shall use the letter */ /* "V" to refer to the product of Householder transformations */ /* (which should be equal to U). */ /* Specifically, if ITYPE=1, then: */ /* RESULT(1) = | U' A U - S | / ( |A| m ulp ) *and* */ /* RESULT(2) = | I - U'U | / ( m ulp ) */ /* Arguments */ /* ========= */ /* ITYPE INTEGER */ /* Specifies the type of tests to be performed. */ /* 1: U expressed as a dense orthogonal matrix: */ /* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and* */ /* RESULT(2) = | I - UU' | / ( n ulp ) */ /* UPLO CHARACTER */ /* If UPLO='U', the upper triangle of A will be used and the */ /* (strictly) lower triangle will not be referenced. If */ /* UPLO='L', the lower triangle of A will be used and the */ /* (strictly) upper triangle will not be referenced. */ /* Not modified. */ /* N INTEGER */ /* The size of the matrix. If it is zero, CHET22 does nothing. */ /* It must be at least zero. */ /* Not modified. */ /* M INTEGER */ /* The number of columns of U. If it is zero, CHET22 does */ /* nothing. It must be at least zero. */ /* Not modified. */ /* KBAND INTEGER */ /* The bandwidth of the matrix. It may only be zero or one. */ /* If zero, then S is diagonal, and E is not referenced. If */ /* one, then S is symmetric tri-diagonal. */ /* Not modified. */ /* A COMPLEX array, dimension (LDA , N) */ /* The original (unfactored) matrix. It is assumed to be */ /* symmetric, and only the upper (UPLO='U') or only the lower */ /* (UPLO='L') will be referenced. */ /* Not modified. */ /* LDA INTEGER */ /* The leading dimension of A. It must be at least 1 */ /* and at least N. */ /* Not modified. */ /* D REAL array, dimension (N) */ /* The diagonal of the (symmetric tri-) diagonal matrix. */ /* Not modified. */ /* E REAL array, dimension (N) */ /* The off-diagonal of the (symmetric tri-) diagonal matrix. */ /* E(1) is ignored, E(2) is the (1,2) and (2,1) element, etc. */ /* Not referenced if KBAND=0. */ /* Not modified. */ /* U COMPLEX array, dimension (LDU, N) */ /* If ITYPE=1, this contains the orthogonal matrix in */ /* the decomposition, expressed as a dense matrix. */ /* Not modified. */ /* LDU INTEGER */ /* The leading dimension of U. LDU must be at least N and */ /* at least 1. */ /* Not modified. */ /* V COMPLEX array, dimension (LDV, N) */ /* If ITYPE=2 or 3, the lower triangle of this array contains */ /* the Householder vectors used to describe the orthogonal */ /* matrix in the decomposition. If ITYPE=1, then it is not */ /* referenced. */ /* Not modified. */ /* LDV INTEGER */ /* The leading dimension of V. LDV must be at least N and */ /* at least 1. */ /* Not modified. */ /* TAU COMPLEX array, dimension (N) */ /* If ITYPE >= 2, then TAU(j) is the scalar factor of */ /* v(j) v(j)' in the Householder transformation H(j) of */ /* the product U = H(1)...H(n-2) */ /* If ITYPE < 2, then TAU is not referenced. */ /* Not modified. */ /* WORK COMPLEX array, dimension (2*N**2) */ /* Workspace. */ /* Modified. */ /* RWORK REAL array, dimension (N) */ /* Workspace. */ /* Modified. */ /* RESULT REAL array, dimension (2) */ /* The values computed by the two tests described above. The */ /* values are currently limited to 1/ulp, to avoid overflow. */ /* RESULT(1) is always modified. RESULT(2) is modified only */ /* if LDU is at least N. */ /* Modified. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; --d__; --e; u_dim1 = *ldu; u_offset = 1 + u_dim1; u -= u_offset; v_dim1 = *ldv; v_offset = 1 + v_dim1; v -= v_offset; --tau; --work; --rwork; --result; /* Function Body */ result[1] = 0.f; result[2] = 0.f; if (*n <= 0 || *m <= 0) { return 0; } unfl = slamch_("Safe minimum"); ulp = slamch_("Precision"); /* Do Test 1 */ /* Norm of A: */ /* Computing MAX */ r__1 = clanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]); anorm = dmax(r__1,unfl); /* Compute error matrix: */ /* ITYPE=1: error = U' A U - S */ chemm_("L", uplo, n, m, &c_b2, &a[a_offset], lda, &u[u_offset], ldu, & c_b1, &work[1], n); nn = *n * *n; nnp1 = nn + 1; cgemm_("C", "N", m, m, n, &c_b2, &u[u_offset], ldu, &work[1], n, &c_b1, & work[nnp1], n); i__1 = *m; for (j = 1; j <= i__1; ++j) { jj = nn + (j - 1) * *n + j; i__2 = jj; i__3 = jj; i__4 = j; q__1.r = work[i__3].r - d__[i__4], q__1.i = work[i__3].i; work[i__2].r = q__1.r, work[i__2].i = q__1.i; /* L10: */ } if (*kband == 1 && *n > 1) { i__1 = *m; for (j = 2; j <= i__1; ++j) { jj1 = nn + (j - 1) * *n + j - 1; jj2 = nn + (j - 2) * *n + j; i__2 = jj1; i__3 = jj1; i__4 = j - 1; q__1.r = work[i__3].r - e[i__4], q__1.i = work[i__3].i; work[i__2].r = q__1.r, work[i__2].i = q__1.i; i__2 = jj2; i__3 = jj2; i__4 = j - 1; q__1.r = work[i__3].r - e[i__4], q__1.i = work[i__3].i; work[i__2].r = q__1.r, work[i__2].i = q__1.i; /* L20: */ } } wnorm = clanhe_("1", uplo, m, &work[nnp1], n, &rwork[1]); if (anorm > wnorm) { result[1] = wnorm / anorm / (*m * ulp); } else { if (anorm < 1.f) { /* Computing MIN */ r__1 = wnorm, r__2 = *m * anorm; result[1] = dmin(r__1,r__2) / anorm / (*m * ulp); } else { /* Computing MIN */ r__1 = wnorm / anorm, r__2 = (real) (*m); result[1] = dmin(r__1,r__2) / (*m * ulp); } } /* Do Test 2 */ /* Compute U'U - I */ if (*itype == 1) { i__1 = (*n << 1) * *n; cunt01_("Columns", n, m, &u[u_offset], ldu, &work[1], &i__1, &rwork[1] , &result[2]); } return 0; /* End of CHET22 */ } /* chet22_ */
/* Subroutine */ int clarhs_(char *path, char *xtype, char *uplo, char *trans, integer *m, integer *n, integer *kl, integer *ku, integer *nrhs, complex *a, integer *lda, complex *x, integer *ldx, complex *b, integer *ldb, integer *iseed, integer *info) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, x_dim1, x_offset, i__1; /* Local variables */ integer j; char c1[1], c2[2]; integer mb, nx; logical gen, tri, qrs, sym, band; char diag[1]; logical tran; extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *), chemm_(char *, char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *), cgbmv_(char *, integer *, integer *, integer *, integer * , complex *, complex *, integer *, complex *, integer *, complex * , complex *, integer *), chbmv_(char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *); extern /* Subroutine */ int csbmv_(char *, integer *, integer *, complex * , complex *, integer *, complex *, integer *, complex *, complex * , integer *), ctbmv_(char *, char *, char *, integer *, integer *, complex *, integer *, complex *, integer *), chpmv_(char *, integer *, complex *, complex *, complex *, integer *, complex *, complex *, integer *), ctrmm_(char *, char *, char *, char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *), cspmv_(char *, integer *, complex *, complex *, complex *, integer *, complex *, complex *, integer *), csymm_(char *, char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *), ctpmv_(char *, char *, char *, integer *, complex *, complex *, integer *), clacpy_(char *, integer *, integer *, complex *, integer *, complex *, integer *), xerbla_(char *, integer *); extern logical lsamen_(integer *, char *, char *); extern /* Subroutine */ int clarnv_(integer *, integer *, integer *, complex *); logical notran; /* -- LAPACK test routine (version 3.1) -- */ /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ /* November 2006 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* Purpose */ /* ======= */ /* CLARHS chooses a set of NRHS random solution vectors and sets */ /* up the right hand sides for the linear system */ /* op( A ) * X = B, */ /* where op( A ) may be A, A**T (transpose of A), or A**H (conjugate */ /* transpose of A). */ /* Arguments */ /* ========= */ /* PATH (input) CHARACTER*3 */ /* The type of the complex matrix A. PATH may be given in any */ /* combination of upper and lower case. Valid paths include */ /* xGE: General m x n matrix */ /* xGB: General banded matrix */ /* xPO: Hermitian positive definite, 2-D storage */ /* xPP: Hermitian positive definite packed */ /* xPB: Hermitian positive definite banded */ /* xHE: Hermitian indefinite, 2-D storage */ /* xHP: Hermitian indefinite packed */ /* xHB: Hermitian indefinite banded */ /* xSY: Symmetric indefinite, 2-D storage */ /* xSP: Symmetric indefinite packed */ /* xSB: Symmetric indefinite banded */ /* xTR: Triangular */ /* xTP: Triangular packed */ /* xTB: Triangular banded */ /* xQR: General m x n matrix */ /* xLQ: General m x n matrix */ /* xQL: General m x n matrix */ /* xRQ: General m x n matrix */ /* where the leading character indicates the precision. */ /* XTYPE (input) CHARACTER*1 */ /* Specifies how the exact solution X will be determined: */ /* = 'N': New solution; generate a random X. */ /* = 'C': Computed; use value of X on entry. */ /* UPLO (input) CHARACTER*1 */ /* Used only if A is symmetric or triangular; specifies whether */ /* the upper or lower triangular part of the matrix A is stored. */ /* = 'U': Upper triangular */ /* = 'L': Lower triangular */ /* TRANS (input) CHARACTER*1 */ /* Used only if A is nonsymmetric; specifies the operation */ /* applied to the matrix A. */ /* = 'N': B := A * X */ /* = 'T': B := A**T * X */ /* = 'C': B := A**H * X */ /* M (input) INTEGER */ /* The number of rows of the matrix A. M >= 0. */ /* N (input) INTEGER */ /* The number of columns of the matrix A. N >= 0. */ /* KL (input) INTEGER */ /* Used only if A is a band matrix; specifies the number of */ /* subdiagonals of A if A is a general band matrix or if A is */ /* symmetric or triangular and UPLO = 'L'; specifies the number */ /* of superdiagonals of A if A is symmetric or triangular and */ /* UPLO = 'U'. 0 <= KL <= M-1. */ /* KU (input) INTEGER */ /* Used only if A is a general band matrix or if A is */ /* triangular. */ /* If PATH = xGB, specifies the number of superdiagonals of A, */ /* and 0 <= KU <= N-1. */ /* If PATH = xTR, xTP, or xTB, specifies whether or not the */ /* matrix has unit diagonal: */ /* = 1: matrix has non-unit diagonal (default) */ /* = 2: matrix has unit diagonal */ /* NRHS (input) INTEGER */ /* The number of right hand side vectors in the system A*X = B. */ /* A (input) COMPLEX array, dimension (LDA,N) */ /* The test matrix whose type is given by PATH. */ /* LDA (input) INTEGER */ /* The leading dimension of the array A. */ /* If PATH = xGB, LDA >= KL+KU+1. */ /* If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1. */ /* Otherwise, LDA >= max(1,M). */ /* X (input or output) COMPLEX array, dimension (LDX,NRHS) */ /* On entry, if XTYPE = 'C' (for 'Computed'), then X contains */ /* the exact solution to the system of linear equations. */ /* On exit, if XTYPE = 'N' (for 'New'), then X is initialized */ /* with random values. */ /* LDX (input) INTEGER */ /* The leading dimension of the array X. If TRANS = 'N', */ /* LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M). */ /* B (output) COMPLEX array, dimension (LDB,NRHS) */ /* The right hand side vector(s) for the system of equations, */ /* computed from B = op(A) * X, where op(A) is determined by */ /* TRANS. */ /* LDB (input) INTEGER */ /* The leading dimension of the array B. If TRANS = 'N', */ /* LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N). */ /* ISEED (input/output) INTEGER array, dimension (4) */ /* The seed vector for the random number generator (used in */ /* CLATMS). Modified on exit. */ /* INFO (output) INTEGER */ /* = 0: successful exit */ /* < 0: if INFO = -i, the i-th argument had an illegal value */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input parameters. */ /* Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1; a -= a_offset; x_dim1 = *ldx; x_offset = 1 + x_dim1; x -= x_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1; b -= b_offset; --iseed; /* Function Body */ *info = 0; *(unsigned char *)c1 = *(unsigned char *)path; s_copy(c2, path + 1, (ftnlen)2, (ftnlen)2); tran = lsame_(trans, "T") || lsame_(trans, "C"); notran = ! tran; gen = lsame_(path + 1, "G"); qrs = lsame_(path + 1, "Q") || lsame_(path + 2, "Q"); sym = lsame_(path + 1, "P") || lsame_(path + 1, "S") || lsame_(path + 1, "H"); tri = lsame_(path + 1, "T"); band = lsame_(path + 2, "B"); if (! lsame_(c1, "Complex precision")) { *info = -1; } else if (! (lsame_(xtype, "N") || lsame_(xtype, "C"))) { *info = -2; } else if ((sym || tri) && ! (lsame_(uplo, "U") || lsame_(uplo, "L"))) { *info = -3; } else if ((gen || qrs) && ! (tran || lsame_(trans, "N"))) { *info = -4; } else if (*m < 0) { *info = -5; } else if (*n < 0) { *info = -6; } else if (band && *kl < 0) { *info = -7; } else if (band && *ku < 0) { *info = -8; } else if (*nrhs < 0) { *info = -9; } else if (! band && *lda < max(1,*m) || band && (sym || tri) && *lda < * kl + 1 || band && gen && *lda < *kl + *ku + 1) { *info = -11; } else if (notran && *ldx < max(1,*n) || tran && *ldx < max(1,*m)) { *info = -13; } else if (notran && *ldb < max(1,*m) || tran && *ldb < max(1,*n)) { *info = -15; } if (*info != 0) { i__1 = -(*info); xerbla_("CLARHS", &i__1); return 0; } /* Initialize X to NRHS random vectors unless XTYPE = 'C'. */ if (tran) { nx = *m; mb = *n; } else { nx = *n; mb = *m; } if (! lsame_(xtype, "C")) { i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { clarnv_(&c__2, &iseed[1], n, &x[j * x_dim1 + 1]); /* L10: */ } } /* Multiply X by op( A ) using an appropriate */ /* matrix multiply routine. */ if (lsamen_(&c__2, c2, "GE") || lsamen_(&c__2, c2, "QR") || lsamen_(&c__2, c2, "LQ") || lsamen_(&c__2, c2, "QL") || lsamen_(&c__2, c2, "RQ")) { /* General matrix */ cgemm_(trans, "N", &mb, nrhs, &nx, &c_b1, &a[a_offset], lda, &x[ x_offset], ldx, &c_b2, &b[b_offset], ldb); } else if (lsamen_(&c__2, c2, "PO") || lsamen_(& c__2, c2, "HE")) { /* Hermitian matrix, 2-D storage */ chemm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset], ldx, &c_b2, &b[b_offset], ldb); } else if (lsamen_(&c__2, c2, "SY")) { /* Symmetric matrix, 2-D storage */ csymm_("Left", uplo, n, nrhs, &c_b1, &a[a_offset], lda, &x[x_offset], ldx, &c_b2, &b[b_offset], ldb); } else if (lsamen_(&c__2, c2, "GB")) { /* General matrix, band storage */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { cgbmv_(trans, m, n, kl, ku, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1); /* L20: */ } } else if (lsamen_(&c__2, c2, "PB") || lsamen_(& c__2, c2, "HB")) { /* Hermitian matrix, band storage */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { chbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1); /* L30: */ } } else if (lsamen_(&c__2, c2, "SB")) { /* Symmetric matrix, band storage */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { csbmv_(uplo, n, kl, &c_b1, &a[a_offset], lda, &x[j * x_dim1 + 1], &c__1, &c_b2, &b[j * b_dim1 + 1], &c__1); /* L40: */ } } else if (lsamen_(&c__2, c2, "PP") || lsamen_(& c__2, c2, "HP")) { /* Hermitian matrix, packed storage */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { chpmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, & c_b2, &b[j * b_dim1 + 1], &c__1); /* L50: */ } } else if (lsamen_(&c__2, c2, "SP")) { /* Symmetric matrix, packed storage */ i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { cspmv_(uplo, n, &c_b1, &a[a_offset], &x[j * x_dim1 + 1], &c__1, & c_b2, &b[j * b_dim1 + 1], &c__1); /* L60: */ } } else if (lsamen_(&c__2, c2, "TR")) { /* Triangular matrix. Note that for triangular matrices, */ /* KU = 1 => non-unit triangular */ /* KU = 2 => unit triangular */ clacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb); if (*ku == 2) { *(unsigned char *)diag = 'U'; } else { *(unsigned char *)diag = 'N'; } ctrmm_("Left", uplo, trans, diag, n, nrhs, &c_b1, &a[a_offset], lda, & b[b_offset], ldb); } else if (lsamen_(&c__2, c2, "TP")) { /* Triangular matrix, packed storage */ clacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb); if (*ku == 2) { *(unsigned char *)diag = 'U'; } else { *(unsigned char *)diag = 'N'; } i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { ctpmv_(uplo, trans, diag, n, &a[a_offset], &b[j * b_dim1 + 1], & c__1); /* L70: */ } } else if (lsamen_(&c__2, c2, "TB")) { /* Triangular matrix, banded storage */ clacpy_("Full", n, nrhs, &x[x_offset], ldx, &b[b_offset], ldb); if (*ku == 2) { *(unsigned char *)diag = 'U'; } else { *(unsigned char *)diag = 'N'; } i__1 = *nrhs; for (j = 1; j <= i__1; ++j) { ctbmv_(uplo, trans, diag, n, kl, &a[a_offset], lda, &b[j * b_dim1 + 1], &c__1); /* L80: */ } } else { /* If none of the above, set INFO = -1 and return */ *info = -1; i__1 = -(*info); xerbla_("CLARHS", &i__1); } return 0; /* End of CLARHS */ } /* clarhs_ */
/* Subroutine */ int csgt01_(integer *itype, char *uplo, integer *n, integer * m, complex *a, integer *lda, complex *b, integer *ldb, complex *z__, integer *ldz, real *d__, complex *work, real *rwork, real *result) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, z_dim1, z_offset, i__1; complex q__1; /* Local variables */ static integer i__; extern /* Subroutine */ int chemm_(char *, char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *); static real anorm; extern doublereal clange_(char *, integer *, integer *, complex *, integer *, real *), clanhe_(char *, char *, integer *, complex *, integer *, real *), slamch_(char *); extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer *); static real ulp; #define z___subscr(a_1,a_2) (a_2)*z_dim1 + a_1 #define z___ref(a_1,a_2) z__[z___subscr(a_1,a_2)] /* -- LAPACK test routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University June 30, 1999 modified August 1997, a new parameter M is added to the calling sequence. Purpose ======= CSGT01 checks a decomposition of the form A Z = B Z D or A B Z = Z D or B A Z = Z D where A is a Hermitian matrix, B is Hermitian positive definite, Z is unitary, and D is diagonal. One of the following test ratios is computed: ITYPE = 1: RESULT(1) = | A Z - B Z D | / ( |A| |Z| n ulp ) ITYPE = 2: RESULT(1) = | A B Z - Z D | / ( |A| |Z| n ulp ) ITYPE = 3: RESULT(1) = | B A Z - Z D | / ( |A| |Z| n ulp ) Arguments ========= ITYPE (input) INTEGER The form of the Hermitian generalized eigenproblem. = 1: A*z = (lambda)*B*z = 2: A*B*z = (lambda)*z = 3: B*A*z = (lambda)*z UPLO (input) CHARACTER*1 Specifies whether the upper or lower triangular part of the Hermitian matrices A and B is stored. = 'U': Upper triangular = 'L': Lower triangular N (input) INTEGER The order of the matrix A. N >= 0. M (input) INTEGER The number of eigenvalues found. M >= 0. A (input) COMPLEX array, dimension (LDA, N) The original Hermitian matrix A. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,N). B (input) COMPLEX array, dimension (LDB, N) The original Hermitian positive definite matrix B. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,N). Z (input) COMPLEX array, dimension (LDZ, M) The computed eigenvectors of the generalized eigenproblem. LDZ (input) INTEGER The leading dimension of the array Z. LDZ >= max(1,N). D (input) REAL array, dimension (M) The computed eigenvalues of the generalized eigenproblem. WORK (workspace) COMPLEX array, dimension (N*N) RWORK (workspace) REAL array, dimension (N) RESULT (output) REAL array, dimension (1) The test ratio as described above. ===================================================================== Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; z_dim1 = *ldz; z_offset = 1 + z_dim1 * 1; z__ -= z_offset; --d__; --work; --rwork; --result; /* Function Body */ result[1] = 0.f; if (*n <= 0) { return 0; } ulp = slamch_("Epsilon"); /* Compute product of 1-norms of A and Z. */ anorm = clanhe_("1", uplo, n, &a[a_offset], lda, &rwork[1]) * clange_("1", n, m, &z__[z_offset], ldz, &rwork[1]); if (anorm == 0.f) { anorm = 1.f; } if (*itype == 1) { /* Norm of AZ - BZD */ chemm_("Left", uplo, n, m, &c_b2, &a[a_offset], lda, &z__[z_offset], ldz, &c_b1, &work[1], n); i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { csscal_(n, &d__[i__], &z___ref(1, i__), &c__1); /* L10: */ } q__1.r = -1.f, q__1.i = 0.f; chemm_("Left", uplo, n, m, &c_b2, &b[b_offset], ldb, &z__[z_offset], ldz, &q__1, &work[1], n); result[1] = clange_("1", n, m, &work[1], n, &rwork[1]) / anorm / (*n * ulp); } else if (*itype == 2) { /* Norm of ABZ - ZD */ chemm_("Left", uplo, n, m, &c_b2, &b[b_offset], ldb, &z__[z_offset], ldz, &c_b1, &work[1], n); i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { csscal_(n, &d__[i__], &z___ref(1, i__), &c__1); /* L20: */ } q__1.r = -1.f, q__1.i = 0.f; chemm_("Left", uplo, n, m, &c_b2, &a[a_offset], lda, &work[1], n, & q__1, &z__[z_offset], ldz); result[1] = clange_("1", n, m, &z__[z_offset], ldz, &rwork[1]) / anorm / (*n * ulp); } else if (*itype == 3) { /* Norm of BAZ - ZD */ chemm_("Left", uplo, n, m, &c_b2, &a[a_offset], lda, &z__[z_offset], ldz, &c_b1, &work[1], n); i__1 = *m; for (i__ = 1; i__ <= i__1; ++i__) { csscal_(n, &d__[i__], &z___ref(1, i__), &c__1); /* L30: */ } q__1.r = -1.f, q__1.i = 0.f; chemm_("Left", uplo, n, m, &c_b2, &b[b_offset], ldb, &work[1], n, & q__1, &z__[z_offset], ldz); result[1] = clange_("1", n, m, &z__[z_offset], ldz, &rwork[1]) / anorm / (*n * ulp); } return 0; /* End of CSGT01 */ } /* csgt01_ */
void cblas_chemm(const enum CBLAS_ORDER Order, const enum CBLAS_SIDE Side, const enum CBLAS_UPLO Uplo, const integer M, const integer N, const void *alpha, const void *A, const integer lda, const void *B, const integer ldb, const void *beta, void *C, const integer ldc) { char SD, UL; #ifdef F77_CHAR F77_CHAR F77_SD, F77_UL; #else #define F77_SD &SD #define F77_UL &UL #endif #define F77_M M #define F77_N N #define F77_lda lda #define F77_ldb ldb #define F77_ldc ldc extern integer CBLAS_CallFromC; extern integer RowMajorStrg; RowMajorStrg = 0; CBLAS_CallFromC = 1; if( Order == CblasColMajor ) { if( Side == CblasRight) SD='R'; else if ( Side == CblasLeft ) SD='L'; else { cblas_xerbla(2, "cblas_chemm", "Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } if( Uplo == CblasUpper) UL='U'; else if ( Uplo == CblasLower ) UL='L'; else { cblas_xerbla(3, "cblas_chemm", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); F77_SD = C2F_CHAR(&SD); #endif chemm_(F77_SD, F77_UL, &F77_M, &F77_N, alpha, A, &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); } else if (Order == CblasRowMajor) { RowMajorStrg = 1; if( Side == CblasRight) SD='L'; else if ( Side == CblasLeft ) SD='R'; else { cblas_xerbla(2, "cblas_chemm", "Illegal Side setting, %d\n", Side); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } if( Uplo == CblasUpper) UL='L'; else if ( Uplo == CblasLower ) UL='U'; else { cblas_xerbla(3, "cblas_chemm", "Illegal Uplo setting, %d\n", Uplo); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; } #ifdef F77_CHAR F77_UL = C2F_CHAR(&UL); F77_SD = C2F_CHAR(&SD); #endif chemm_(F77_SD, F77_UL, &F77_N, &F77_M, alpha, A, &F77_lda, B, &F77_ldb, beta, C, &F77_ldc); } else cblas_xerbla(1, "cblas_chemm", "Illegal Order setting, %d\n", Order); CBLAS_CallFromC = 0; RowMajorStrg = 0; return; }