Télécharger la plaquette Cast3M


fr en

Télécharger dnrm2.eso

Retour à la liste

Numérotation des lignes : 

dnrm2

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

© Cast3M 2003 - Tous droits réservés.
Mentions légales