1 /*
2  * cblas_zhpr2.c
3  * The program is a C interface to zhpr2.
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"
cblas_zhpr2(const enum CBLAS_ORDER order,const enum CBLAS_UPLO Uplo,const int N,const void * alpha,const void * X,const int incX,const void * Y,const int incY,void * Ap)12 void cblas_zhpr2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
13                       const int N,const void *alpha, const void *X,
14                       const int incX,const void *Y, const int incY, void *Ap)
15 
16 {
17    char UL;
18 #ifdef F77_CHAR
19    F77_CHAR F77_UL;
20 #else
21    #define F77_UL &UL
22 #endif
23 
24 #ifdef F77_INT
25    F77_INT F77_N=N,  F77_incX=incX, F77_incY=incY;
26 #else
27    #define F77_N N
28    #define F77_incX incx
29    #define F77_incY incy
30 #endif
31    int n, i, j, incx=incX, incy=incY;
32    double *x=(double *)X, *xx=(double *)X, *y=(double *)Y,
33          *yy=(double *)Y, *stx, *sty;
34 
35    extern int CBLAS_CallFromC;
36    extern int RowMajorStrg;
37    RowMajorStrg = 0;
38 
39    CBLAS_CallFromC = 1;
40    if (order == CblasColMajor)
41    {
42       if (Uplo == CblasLower) UL = 'L';
43       else if (Uplo == CblasUpper) UL = 'U';
44       else
45       {
46          cblas_xerbla(2, "cblas_zhpr2","Illegal Uplo setting, %d\n",Uplo );
47          CBLAS_CallFromC = 0;
48          RowMajorStrg = 0;
49          return;
50       }
51       #ifdef F77_CHAR
52          F77_UL = C2F_CHAR(&UL);
53       #endif
54 
55       F77_zhpr2(F77_UL, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, Ap);
56 
57    }  else if (order == CblasRowMajor)
58    {
59       RowMajorStrg = 1;
60       if (Uplo == CblasUpper) UL = 'L';
61       else if (Uplo == CblasLower) UL = 'U';
62       else
63       {
64          cblas_xerbla(2, "cblas_zhpr2","Illegal Uplo setting, %d\n", Uplo);
65          CBLAS_CallFromC = 0;
66          RowMajorStrg = 0;
67          return;
68       }
69       #ifdef F77_CHAR
70          F77_UL = C2F_CHAR(&UL);
71       #endif
72       if (N > 0)
73       {
74          n = N << 1;
75          x = malloc(n*sizeof(double));
76          y = malloc(n*sizeof(double));
77          stx = x + n;
78          sty = y + n;
79          if( incX > 0 )
80             i = incX << 1;
81          else
82             i = incX *(-2);
83 
84          if( incY > 0 )
85             j = incY << 1;
86          else
87             j = incY *(-2);
88          do
89          {
90             *x = *xx;
91             x[1] = -xx[1];
92             x += 2;
93             xx += i;
94          } while (x != stx);
95          do
96          {
97             *y = *yy;
98             y[1] = -yy[1];
99             y += 2;
100             yy += j;
101          }
102          while (y != sty);
103          x -= n;
104          y -= n;
105 
106          #ifdef F77_INT
107             if(incX > 0 )
108                F77_incX = 1;
109             else
110                F77_incX = -1;
111 
112             if(incY > 0 )
113                F77_incY = 1;
114             else
115                F77_incY = -1;
116 
117          #else
118             if(incX > 0 )
119                incx = 1;
120             else
121                incx = -1;
122 
123             if(incY > 0 )
124                incy = 1;
125             else
126                incy = -1;
127          #endif
128 
129       }  else
130       {
131          x = (double *) X;
132          y = (void  *) Y;
133       }
134       F77_zhpr2(F77_UL, &F77_N, alpha, y, &F77_incY, x, &F77_incX, Ap);
135    }
136    else
137    {
138       cblas_xerbla(1, "cblas_zhpr2","Illegal Order setting, %d\n", order);
139       CBLAS_CallFromC = 0;
140       RowMajorStrg = 0;
141       return;
142    }
143    if(X!=x)
144       free(x);
145    if(Y!=y)
146       free(y);
147    CBLAS_CallFromC = 0;
148    RowMajorStrg = 0;
149    return;
150 }
151