1 /* 2 * cblas_zher.c 3 * The program is a C interface to zher. 4 * 5 * Keita Teranishi 5/20/98 6 * 7 */ 8 #include <stdio.h> 9 #include <stdlib.h> 10 #include "cblas.h" 11 #include "cblas_f77.h" 12 void cblas_zher(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo, 13 const int N, const double alpha, const void *X, const int incX 14 ,void *A, const int lda) 15 { 16 char UL; 17 #ifdef F77_CHAR 18 F77_CHAR F77_UL; 19 #else 20 #define F77_UL &UL 21 #endif 22 23 #ifdef F77_INT 24 F77_INT F77_N=N, F77_lda=lda, F77_incX=incX; 25 #else 26 #define F77_N N 27 #define F77_lda lda 28 #define F77_incX incx 29 #endif 30 int n, i, tincx, incx=incX; 31 double *x=(double *)X, *xx=(double *)X, *tx, *st; 32 33 extern int CBLAS_CallFromC; 34 extern int RowMajorStrg; 35 RowMajorStrg = 0; 36 37 CBLAS_CallFromC = 1; 38 if (order == CblasColMajor) 39 { 40 if (Uplo == CblasLower) UL = 'L'; 41 else if (Uplo == CblasUpper) UL = 'U'; 42 else 43 { 44 cblas_xerbla(2, "cblas_zher","Illegal Uplo setting, %d\n",Uplo ); 45 CBLAS_CallFromC = 0; 46 RowMajorStrg = 0; 47 return; 48 } 49 #ifdef F77_CHAR 50 F77_UL = C2F_CHAR(&UL); 51 #endif 52 53 F77_zher(F77_UL, &F77_N, &alpha, X, &F77_incX, A, &F77_lda); 54 55 } else if (order == CblasRowMajor) 56 { 57 RowMajorStrg = 1; 58 if (Uplo == CblasUpper) UL = 'L'; 59 else if (Uplo == CblasLower) UL = 'U'; 60 else 61 { 62 cblas_xerbla(2, "cblas_zher","Illegal Uplo setting, %d\n", Uplo); 63 CBLAS_CallFromC = 0; 64 RowMajorStrg = 0; 65 return; 66 } 67 #ifdef F77_CHAR 68 F77_UL = C2F_CHAR(&UL); 69 #endif 70 if (N > 0) 71 { 72 n = N << 1; 73 x = malloc(n*sizeof(double)); 74 tx = x; 75 if( incX > 0 ) { 76 i = incX << 1 ; 77 tincx = 2; 78 st= x+n; 79 } else { 80 i = incX *(-2); 81 tincx = -2; 82 st = x-2; 83 x +=(n-2); 84 } 85 do 86 { 87 *x = *xx; 88 x[1] = -xx[1]; 89 x += tincx ; 90 xx += i; 91 } 92 while (x != st); 93 x=tx; 94 95 #ifdef F77_INT 96 F77_incX = 1; 97 #else 98 incx = 1; 99 #endif 100 } 101 else x = (double *) X; 102 F77_zher(F77_UL, &F77_N, &alpha, x, &F77_incX, A, &F77_lda); 103 } else cblas_xerbla(1, "cblas_zher", "Illegal Order setting, %d\n", order); 104 if(X!=x) 105 free(x); 106 107 CBLAS_CallFromC = 0; 108 RowMajorStrg = 0; 109 return; 110 } 111
