Home | History | Annotate | Download | only in src 
      1 /*
      2  * cblas_zher2.c
      3  * The program is a C interface to zher2.
      4  *
      5  * Keita Teranishi  3/23/98
      6  *
      7  */
      8 #include <stdio.h>
      9 #include <stdlib.h>
     10 #include "cblas.h"
     11 #include "cblas_f77.h"
     12 void cblas_zher2(const enum CBLAS_ORDER order, const enum CBLAS_UPLO Uplo,
     13                  const int N, const void *alpha, const void *X, const int incX,
     14                  const void *Y, const int incY, void *A, const int lda)
     15 {
     16    char UL;
     17 #ifdef F77_CHAR
     18    F77_CHAR F77_UL;
     19 #else
     20    #define F77_UL &UL
     21 #endif
     22 
     23 #ifdef F77_INT
     24    F77_INT F77_N=N, F77_lda=lda, F77_incX=incX, F77_incY=incY;
     25 #else
     26    #define F77_N N
     27    #define F77_lda lda
     28    #define F77_incX incx
     29    #define F77_incY incy
     30 #endif
     31    int n, i, j, tincx, tincy, incx=incX, incy=incY;
     32    double *x=(double *)X, *xx=(double *)X, *y=(double *)Y,
     33          *yy=(double *)Y, *tx, *ty, *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_zher2", "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_zher2(F77_UL, &F77_N, alpha, X, &F77_incX,
     56                                             Y, &F77_incY, A, &F77_lda);
     57 
     58    }  else if (order == CblasRowMajor)
     59    {
     60       RowMajorStrg = 1;
     61       if (Uplo == CblasUpper) UL = 'L';
     62       else if (Uplo == CblasLower) UL = 'U';
     63       else
     64       {
     65          cblas_xerbla(2, "cblas_zher2", "Illegal Uplo setting, %d\n", Uplo);
     66          CBLAS_CallFromC = 0;
     67          RowMajorStrg = 0;
     68          return;
     69       }
     70       #ifdef F77_CHAR
     71          F77_UL = C2F_CHAR(&UL);
     72       #endif
     73       if (N > 0)
     74       {
     75          n = N << 1;
     76          x = malloc(n*sizeof(double));
     77          y = malloc(n*sizeof(double));
     78          tx = x;
     79          ty = y;
     80          if( incX > 0 ) {
     81             i = incX << 1 ;
     82             tincx = 2;
     83             stx= x+n;
     84          } else {
     85             i = incX *(-2);
     86             tincx = -2;
     87             stx = x-2;
     88             x +=(n-2);
     89          }
     90 
     91          if( incY > 0 ) {
     92             j = incY << 1;
     93             tincy = 2;
     94             sty= y+n;
     95          } else {
     96             j = incY *(-2);
     97             tincy = -2;
     98             sty = y-2;
     99             y +=(n-2);
    100          }
    101 
    102          do
    103          {
    104             *x = *xx;
    105             x[1] = -xx[1];
    106             x += tincx ;
    107             xx += i;
    108          }
    109          while (x != stx);
    110 
    111          do
    112          {
    113             *y = *yy;
    114             y[1] = -yy[1];
    115             y += tincy ;
    116             yy += j;
    117          }
    118          while (y != sty);
    119 
    120          x=tx;
    121          y=ty;
    122 
    123          #ifdef F77_INT
    124             F77_incX = 1;
    125             F77_incY = 1;
    126          #else
    127             incx = 1;
    128             incy = 1;
    129          #endif
    130       }  else
    131       {
    132          x = (double *) X;
    133          y = (double *) Y;
    134       }
    135       F77_zher2(F77_UL, &F77_N, alpha, y, &F77_incY, x,
    136                                       &F77_incX, A, &F77_lda);
    137    }
    138    else
    139    {
    140       cblas_xerbla(1, "cblas_zher2", "Illegal Order setting, %d\n", order);
    141       CBLAS_CallFromC = 0;
    142       RowMajorStrg = 0;
    143       return;
    144    }
    145    if(X!=x)
    146       free(x);
    147    if(Y!=y)
    148       free(y);
    149 
    150    CBLAS_CallFromC = 0;
    151    RowMajorStrg = 0;
    152    return;
    153 }
    154