Télécharger la plaquette Cast3M


fr en

Télécharger dvperm.eso

Retour à la liste

Numérotation des lignes : 

dvperm

  1. C DVPERM    SOURCE    CHAT      05/01/12    22:59:02     5004
  2.       SUBROUTINE DVPERM (N, X, PERM)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8 (A-H,O-Z)
  5. C***********************************************************************
  6. C NOM         : IVPERM
  7. C DESCRIPTION : Permutation d'un tableau de réels.
  8. C
  9. C
  10. C LANGAGE     : FORTRAN 77
  11. C ADAPTATION  :  Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF)
  12. C                mél : gounand@semt2.smts.cea.fr
  13. C AUTEUR      :
  14. C  Sparskit : a basic tool kit for sparse matrix computations
  15. C  Version 2 (Youcef Saad)
  16. C  -> URL : http://www.cs.umn.edu/Research/arpa/SPARSKIT/sparskit.html
  17. C
  18. C***********************************************************************
  19.       INTEGER N, PERM(N)
  20.       REAL*8 X(N)
  21. c-----------------------------------------------------------------------
  22. c this subroutine performs an in-place permutation of a real vector x
  23. c according to the permutation array perm(*), i.e., on return,
  24. c the vector x satisfies,
  25. c
  26. c       x(perm(j)) :== x(j), j=1,2,.., n
  27. c
  28. c-----------------------------------------------------------------------
  29. c on entry:
  30. c---------
  31. c n     = length of vector x.
  32. c perm  = integer array of length n containing the permutation  array.
  33. c x     = input vector
  34. c
  35. c on return:
  36. c----------
  37. c x     = vector x permuted according to x(perm(*)) :=  x(*)
  38. c
  39. c----------------------------------------------------------------------c
  40. c           Y. Saad, Sep. 21 1989                                      c
  41. c----------------------------------------------------------------------c
  42. c local variables
  43.       REAL*8 TMP, TMP1
  44.       INTEGER II,J,K,INIT,NEXT
  45. c
  46.       INIT      = 1
  47.       TMP       = X(INIT)
  48.       II        = PERM(INIT)
  49.       PERM(INIT)= -PERM(INIT)
  50.       K         = 0
  51. c
  52. c loop
  53. c
  54.  6    CONTINUE
  55.       K = K+1
  56. c
  57. c save the chased element --
  58. c
  59.       TMP1        = X(II)
  60.       X(II)     = TMP
  61.       NEXT        = PERM(II)
  62.       IF (NEXT .LT. 0 ) GOTO 65
  63. c
  64. c test for end
  65. c
  66.       IF (K .GT. N) GOTO 101
  67.       TMP       = TMP1
  68.       PERM(II)  = - PERM(II)
  69.       II        = NEXT
  70. c
  71. c end loop
  72. c
  73.       GOTO 6
  74. c
  75. c reinitilaize cycle --
  76. c
  77.  65   INIT      = INIT+1
  78.       IF (INIT .GT. N) GOTO 101
  79.       IF (PERM(INIT) .LT. 0) GOTO 65
  80.       TMP       = X(INIT)
  81.       II        = PERM(INIT)
  82.       PERM(INIT)=-PERM(INIT)
  83.       GOTO 6
  84. c
  85.  101  CONTINUE
  86.       DO 200 J=1, N
  87.          PERM(J) = -PERM(J)
  88.  200  CONTINUE
  89. c
  90.       RETURN
  91. c-------------------end-of-dvperm---------------------------------------
  92. c-----------------------------------------------------------------------
  93.       END
  94.  
  95.  
  96.  

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