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