src/gmxlib/gmx_lapack/slanst.c

   1 #include <math.h>
   2 #include <ctype.h>
   3 #include "gmx_lapack.h"
   4
   5
   6 float
   7 F77_FUNC(slanst,SLANST)(const char *norm,
   8         int *n,
   9         float *d,
  10         float *e)
  11 {
  12   const char ch=toupper(*norm);
  13   float dtemp,max,val,scale,sum;
  14   int i,j;
  15
  16
  17   if(*n<=0)
  18     return 0.0;
  19
  20   switch(ch) {
  21   case 'M':
  22     max = fabs(d[*n-1]);
  23       for(i=0;i<(*n-1);i++) {
  24         dtemp = fabs(d[i]);
  25         if(dtemp>max)
  26           max = dtemp;
  27         dtemp = fabs(e[i]);
  28         if(dtemp>max)
  29           max = dtemp;
  30       }
  31     val = max;
  32     break;
  33
  34   case 'O':
  35   case '1':
  36   case 'I':
  37
  38     if(*n==1)
  39       val = fabs(d[0]);
  40     else {
  41       max = fabs(d[0]) + fabs(e[0]);
  42       dtemp = fabs(e[*n-2]) + fabs(d[*n-1]);
  43       if(dtemp>max)
  44         max = dtemp;
  45       for(i=1;i<(*n-1);i++) {
  46         dtemp = fabs(d[i]) + fabs(e[i]) + fabs(e[i-1]);
  47         if(dtemp>max)
  48           max = dtemp;
  49       }
  50       val = max;
  51     }
  52     break;
  53
  54   case 'F':
  55   case 'E':
  56     scale = 0.0;
  57     sum   = 1.0;
  58     i = *n-1;
  59     j = 1;
  60     if(*n>1) {
  61       F77_FUNC(slassq,SLASSQ)(&i,e,&j,&scale,&sum);
  62       sum *= 2;
  63     }
  64     F77_FUNC(slassq,SLASSQ)(n,d,&j,&scale,&sum);
  65     val = scale * sqrt(sum);
  66     break;
  67
  68   default:
  69     val = 0.0;
  70     break;
  71   }
  72   return val;
  73 }