001: /*
002:  * cblas_chpr2.c
003:  * The program is a C interface to chpr2.
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_chpr2(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, tincx, tincy, incx=incX, incy=incY;
032:    float *x=(float *)X, *xx=(float *)X, *y=(float *)Y,
033:          *yy=(float *)Y, *tx, *ty, *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_chpr2","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_chpr2(F77_UL, &F77_N, (float *)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_chpr2","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 = (float *)malloc(n*sizeof(float));
076:          y = (float *)malloc(n*sizeof(float));
077:          tx = x;
078:          ty = y;
079:          if( incX > 0 ) {
080:             i = incX << 1 ;
081:             tincx = 2;
082:             stx= x+n;
083:          } else {
084:             i = incX *(-2);
085:             tincx = -2;
086:             stx = x-2;
087:             x +=(n-2);
088:          }
089: 
090:          if( incY > 0 ) {
091:             j = incY << 1;
092:             tincy = 2;
093:             sty= y+n;
094:          } else {
095:             j = incY *(-2);
096:             tincy = -2;
097:             sty = y-2;
098:             y +=(n-2);
099:          }
100: 
101:          do
102:          {
103:             *x = *xx;
104:             x[1] = -xx[1];
105:             x += tincx ;
106:             xx += i;
107:          }
108:          while (x != stx);
109:          do
110:          {
111:             *y = *yy;
112:             y[1] = -yy[1];
113:             y += tincy ;
114:             yy += j;
115:          }
116:          while (y != sty);
117: 
118:          x=tx;
119:          y=ty;
120: 
121:          #ifdef F77_INT
122:             F77_incX = 1;
123:             F77_incY = 1;
124:          #else
125:             incx = 1;
126:             incy = 1;
127:          #endif
128: 
129:       }  else
130:       {
131:          x = (float *) X;
132:          y = (float *) Y;
133:       }
134:       F77_chpr2(F77_UL, &F77_N, (const float *)alpha, y, &F77_incY, x, &F77_incX, Ap);
135:    } else
136:    {
137:       cblas_xerbla(1, "cblas_chpr2","Illegal Order setting, %d\n", order);
138:       CBLAS_CallFromC = 0;
139:       RowMajorStrg = 0;
140:       return;
141:    }
142:    if(X!=x)
143:       free(x);
144:    if(Y!=y)
145:       free(y);
146:    CBLAS_CallFromC = 0;
147:    RowMajorStrg = 0;
148:    return;
149: }
150: