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