Esope source files

   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 :