Télécharger dnrm2.eso

Retour à la liste

Numérotation des lignes :

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

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