001: /*
002:  * cblas_zhpr2.c
003:  * The program is a C interface to zhpr2.
004:  *
005:  * Keita Teranishi  5/20/98
006:  *
007:  */
008: #include <stdio.h>
009: #include <stdlib.h>
010: #include "cblas.h"
011: #include "cblas_f77.h"
012: void cblas_zhpr2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
013:                       const int N,const void *alpha, const void *X,
014:                       const int incX,const void *Y, const int incY, void *Ap)
015: 
016: {
017:    char UL;
018: #ifdef F77_CHAR
019:    F77_CHAR F77_UL;
020: #else
021:    #define F77_UL &UL
022: #endif
023: 
024: #ifdef F77_INT
025:    F77_INT F77_N=N,  F77_incX=incX, F77_incY=incY;
026: #else
027:    #define F77_N N
028:    #define F77_incX incx
029:    #define F77_incY incy
030: #endif
031:    int n, i, j, incx=incX, incy=incY;
032:    double *x=(double *)X, *xx=(double *)X, *y=(double *)Y,
033:          *yy=(double *)Y, *stx, *sty;
034: 
035:    extern int CBLAS_CallFromC;
036:    extern int RowMajorStrg;
037:    RowMajorStrg = 0;
038: 
039:    CBLAS_CallFromC = 1;
040:    if (order == CblasColMajor)
041:    {
042:       if (Uplo == CblasLower) UL = 'L';
043:       else if (Uplo == CblasUpper) UL = 'U';
044:       else
045:       {
046:          cblas_xerbla(2, "cblas_zhpr2","Illegal Uplo setting, %d\n",Uplo );
047:          CBLAS_CallFromC = 0;
048:          RowMajorStrg = 0;
049:          return;
050:       }
051:       #ifdef F77_CHAR
052:          F77_UL = C2F_CHAR(&UL);
053:       #endif
054: 
055:       F77_zhpr2(F77_UL, &F77_N, (double *)alpha, X, &F77_incX, Y, &F77_incY, Ap);
056: 
057:    }  else if (order == CblasRowMajor)
058:    {
059:       RowMajorStrg = 1;
060:       if (Uplo == CblasUpper) UL = 'L';
061:       else if (Uplo == CblasLower) UL = 'U';
062:       else
063:       {
064:          cblas_xerbla(2, "cblas_zhpr2","Illegal Uplo setting, %d\n", Uplo);
065:          CBLAS_CallFromC = 0;
066:          RowMajorStrg = 0;
067:          return;
068:       }
069:       #ifdef F77_CHAR
070:          F77_UL = C2F_CHAR(&UL);
071:       #endif
072:       if (N > 0)
073:       {
074:          n = N << 1;
075:          x = (double *)malloc(n*sizeof(double));
076:          y = (double *)malloc(n*sizeof(double));
077:          stx = x + n;
078:          sty = y + n;
079:          if( incX > 0 )
080:             i = incX << 1;
081:          else
082:             i = incX *(-2);
083: 
084:          if( incY > 0 )
085:             j = incY << 1;
086:          else
087:             j = incY *(-2);
088:          do
089:          {
090:             *x = *xx;
091:             x[1] = -xx[1];
092:             x += 2;
093:             xx += i;
094:          } while (x != stx);
095:          do
096:          {
097:             *y = *yy;
098:             y[1] = -yy[1];
099:             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 = (double *) Y;
133:       }
134:       F77_zhpr2(F77_UL, &F77_N, (const double *)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: