001: /*
002:  * cblas_cher.c
003:  * The program is a C interface to cher.
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_cher(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
013:                 const int N, const float alpha, const void *X, const int incX
014:                 ,void *A, const int lda)
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_lda=lda, F77_incX=incX;
025: #else
026:    #define F77_N N
027:    #define F77_lda lda
028:    #define F77_incX incx
029: #endif
030:    int n, i, tincx, incx=incX;
031:    float *x=(float *)X, *xx=(float *)X, *tx, *st;
032: 
033:    extern int CBLAS_CallFromC;
034:    extern int RowMajorStrg;
035:    RowMajorStrg = 0;
036: 
037:    CBLAS_CallFromC = 1;
038:    if (order == CblasColMajor)
039:    {
040:       if (Uplo == CblasLower) UL = 'L';
041:       else if (Uplo == CblasUpper) UL = 'U';
042:       else
043:       {
044:          cblas_xerbla(2, "cblas_cher","Illegal Uplo setting, %d\n",Uplo );
045:          CBLAS_CallFromC = 0;
046:          RowMajorStrg = 0;
047:          return;
048:       }
049:       #ifdef F77_CHAR
050:          F77_UL = C2F_CHAR(&UL);
051:       #endif
052: 
053:       F77_cher(F77_UL, &F77_N, &alpha, X, &F77_incX, A, &F77_lda);
054: 
055:    }  else if (order == CblasRowMajor)
056:    {
057:       RowMajorStrg = 1;
058:       if (Uplo == CblasUpper) UL = 'L';
059:       else if (Uplo == CblasLower) UL = 'U';
060:       else
061:       {
062:          cblas_xerbla(2, "cblas_cher","Illegal Uplo setting, %d\n", Uplo);
063:          CBLAS_CallFromC = 0;
064:          RowMajorStrg = 0;
065:          return;
066:       }
067:       #ifdef F77_CHAR
068:          F77_UL = C2F_CHAR(&UL);
069:       #endif
070:       if (N > 0)
071:       {
072:          n = N << 1;
073:          x = (float *)malloc(n*sizeof(float));
074:          tx = x;
075:          if( incX > 0 ) {
076:             i = incX << 1 ;
077:             tincx = 2;
078:             st= x+n;
079:          } else {
080:             i = incX *(-2);
081:             tincx = -2;
082:             st = x-2;
083:             x +=(n-2);
084:          }
085:          do
086:          {
087:             *x = *xx;
088:             x[1] = -xx[1];
089:             x += tincx ;
090:             xx += i;
091:          }
092:          while (x != st);
093:          x=tx;
094: 
095:          #ifdef F77_INT
096:            F77_incX = 1;
097:          #else
098:            incx = 1;
099:          #endif
100:       }
101:       else x = (float *) X;
102:       F77_cher(F77_UL, &F77_N, &alpha, x, &F77_incX, A, &F77_lda);
103:    } else
104:    {
105:       cblas_xerbla(1, "cblas_cher","Illegal Order setting, %d\n", order);
106:       CBLAS_CallFromC = 0;
107:       RowMajorStrg = 0;
108:       return;
109:    }
110:    if(X!=x)
111:       free(x);
112: 
113:    CBLAS_CallFromC = 0;
114:    RowMajorStrg = 0;
115:    return;
116: }
117: