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