Home | History | Annotate | Download | only in src 
      1 /*
      2  * cblas_zhpr2.c
      3  * The program is a C interface to zhpr2.
      4  *
      5  * Keita Teranishi  5/20/98
      6  *
      7  */
      8 #include <stdio.h>
      9 #include <stdlib.h>
     10 #include "cblas.h"
     11 #include "cblas_f77.h"
     12 void cblas_zhpr2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
     13                       const int N,const void *alpha, const void *X,
     14                       const int incX,const void *Y, const int incY, void *Ap)
     15 
     16 {
     17    char UL;
     18 #ifdef F77_CHAR
     19    F77_CHAR F77_UL;
     20 #else
     21    #define F77_UL &UL
     22 #endif
     23 
     24 #ifdef F77_INT
     25    F77_INT F77_N=N,  F77_incX=incX, F77_incY=incY;
     26 #else
     27    #define F77_N N
     28    #define F77_incX incx
     29    #define F77_incY incy
     30 #endif
     31    int n, i, j, incx=incX, incy=incY;
     32    double *x=(double *)X, *xx=(double *)X, *y=(double *)Y,
     33          *yy=(double *)Y, *stx, *sty;
     34 
     35    extern int CBLAS_CallFromC;
     36    extern int RowMajorStrg;
     37    RowMajorStrg = 0;
     38 
     39    CBLAS_CallFromC = 1;
     40    if (order == CblasColMajor)
     41    {
     42       if (Uplo == CblasLower) UL = 'L';
     43       else if (Uplo == CblasUpper) UL = 'U';
     44       else
     45       {
     46          cblas_xerbla(2, "cblas_zhpr2","Illegal Uplo setting, %d\n",Uplo );
     47          CBLAS_CallFromC = 0;
     48          RowMajorStrg = 0;
     49          return;
     50       }
     51       #ifdef F77_CHAR
     52          F77_UL = C2F_CHAR(&UL);
     53       #endif
     54 
     55       F77_zhpr2(F77_UL, &F77_N, alpha, X, &F77_incX, Y, &F77_incY, Ap);
     56 
     57    }  else if (order == CblasRowMajor)
     58    {
     59       RowMajorStrg = 1;
     60       if (Uplo == CblasUpper) UL = 'L';
     61       else if (Uplo == CblasLower) UL = 'U';
     62       else
     63       {
     64          cblas_xerbla(2, "cblas_zhpr2","Illegal Uplo setting, %d\n", Uplo);
     65          CBLAS_CallFromC = 0;
     66          RowMajorStrg = 0;
     67          return;
     68       }
     69       #ifdef F77_CHAR
     70          F77_UL = C2F_CHAR(&UL);
     71       #endif
     72       if (N > 0)
     73       {
     74          n = N << 1;
     75          x = malloc(n*sizeof(double));
     76          y = malloc(n*sizeof(double));
     77          stx = x + n;
     78          sty = y + n;
     79          if( incX > 0 )
     80             i = incX << 1;
     81          else
     82             i = incX *(-2);
     83 
     84          if( incY > 0 )
     85             j = incY << 1;
     86          else
     87             j = incY *(-2);
     88          do
     89          {
     90             *x = *xx;
     91             x[1] = -xx[1];
     92             x += 2;
     93             xx += i;
     94          } while (x != stx);
     95          do
     96          {
     97             *y = *yy;
     98             y[1] = -yy[1];
     99             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 = (void  *) Y;
    133       }
    134       F77_zhpr2(F77_UL, &F77_N, 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