Esope source files

   1 : C DNRM2     SOURCE    CHAT      06/03/29    21:18:45     5360           
   2 :       FUNCTION DNRM2 ( N, X, INCX )
   3 :       IMPLICIT INTEGER(I-N)
   4 :       IMPLICIT REAL*8 (A-H,O-Z)
   5 : -INC CCOPTIO
   6 : *     .. Scalar Result ..
   7 :       REAL*8                            DNRM2
   8 : *     .. Scalar Arguments ..
   9 :       INTEGER                           INCX, N
  10 : *     .. Array Arguments ..
  11 :       REAL*8                            X( * )
  12 : *     ..
  13 : *     
  14 : *  DNRM2 returns the euclidean norm of a vector via the function
  15 : *  name, so that
  16 : *     
  17 : *     DNRM2 := sqrt( x'*x )
  18 : *     
  19 : *     
  20 : *     
  21 : *  -- This version written on 25-October-1982.
  21 : *     Modified on 14-October-1993 to inline the call to DLASSQ.
  22 : *     Sven Hammarling, Nag Ltd.
  23 : *     
  24 : *     Modified on 16/2/98 double precision -> real*8
  25 : *                         added error handling
  26 : *                         commented INTRINSIC (not esope compatible)
  27 : *                         real*8 function  f -> function f ; real*8 f
  28 : *     .. Parameters ..
  29 :       REAL*8                ONE         , ZERO
  30 :       PARAMETER           ( ONE = 1.0D+0, ZERO = 0.0D+0 )
  31 : *     .. Local Scalars ..
  32 :       INTEGER               IX
  33 :       REAL*8                ABSXI, NORM, SCALE, SSQ
  34 : *     .. Intrinsic Functions ..
  35 : *      INTRINSIC             ABS, SQRT
  36 : *     ..
  37 : *     .. Executable Statements ..
  38 :       IF( N.LT.1 .OR. INCX.LT.1 )THEN
  39 :          NORM  = ZERO
  40 :          GOTO 9999
  41 :       ELSE IF( N.EQ.1 )THEN
  42 :          NORM  = ABS( X( 1 ) )
  43 :       ELSE
  44 :          SCALE = ZERO
  45 :          SSQ   = ONE
  45 : *        The following loop is equivalent to this call to the LAPACK
  46 : *        auxiliary routine:
  46 : *        CALL DLASSQ( N, X, INCX, SCALE, SSQ )
  47 : *     
  48 :          DO 10, IX = 1, 1 + ( N - 1 )*INCX, INCX
  49 :             IF( X( IX ).NE.ZERO )THEN
  50 :                ABSXI = ABS( X( IX ) )
  51 :                IF( SCALE.LT.ABSXI )THEN
  52 :                   SSQ   = ONE   + SSQ*( SCALE/ABSXI )**2
  53 :                   SCALE = ABSXI
  54 :                ELSE
  55 :                   SSQ   = SSQ   +     ( ABSXI/SCALE )**2
  56 :                END IF
  57 :             END IF
  58 :  10      CONTINUE
  59 :          NORM  = SCALE * SQRT( SSQ )
  60 :       END IF
  61 : *     
  62 :       DNRM2 = NORM
  63 :       RETURN
  64 : C     Error handling
  65 :  9999 CONTINUE
  66 :       WRITE(IOIMP,*) 'Dimension or increment lower than 1'
  67 :       WRITE(IOIMP,*) 'transmitted to function dnrm2'
  68 :       WRITE(IOIMP,*) 'nil value returned'
  69 :       DNRM2 = NORM
  69 :       call erreur(21)
  70 :       RETURN
  71 : *     
  72 : *     End of DNRM2.
  73 : *     
  74 :       END
  75 : 
  76 : 
  77 :  
  78 :  
  79 :