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"
12void 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