1*DECK SPPERM
2      SUBROUTINE SPPERM (X, N, IPERM, IER)
3C***BEGIN PROLOGUE  SPPERM
4C***PURPOSE  Rearrange a given array according to a prescribed
5C            permutation vector.
6C***LIBRARY   SLATEC
7C***CATEGORY  N8
8C***TYPE      SINGLE PRECISION (SPPERM-S, DPPERM-D, IPPERM-I, HPPERM-H)
9C***KEYWORDS  APPLICATION OF PERMUTATION TO DATA VECTOR
10C***AUTHOR  McClain, M. A., (NIST)
11C           Rhoads, G. S., (NBS)
12C***DESCRIPTION
13C
14C         SPPERM rearranges the data vector X according to the
15C         permutation IPERM: X(I) <--- X(IPERM(I)).  IPERM could come
16C         from one of the sorting routines IPSORT, SPSORT, DPSORT or
17C         HPSORT.
18C
19C     Description of Parameters
20C         X - input/output -- real array of values to be rearranged.
21C         N - input -- number of values in real array X.
22C         IPERM - input -- permutation vector.
23C         IER - output -- error indicator:
24C             =  0  if no error,
25C             =  1  if N is zero or negative,
26C             =  2  if IPERM is not a valid permutation.
27C
28C***REFERENCES  (NONE)
29C***ROUTINES CALLED  XERMSG
30C***REVISION HISTORY  (YYMMDD)
31C   901004  DATE WRITTEN
32C   920507  Modified by M. McClain to revise prologue text.
33C***END PROLOGUE  SPPERM
34      INTEGER N, IPERM(*), I, IER, INDX, INDX0, ISTRT
35      REAL X(*), TEMP
36C***FIRST EXECUTABLE STATEMENT  SPPERM
37      IER=0
38      IF(N.LT.1)THEN
39         IER=1
40         CALL XERMSG ('SLATEC', 'SPPERM',
41     +    'The number of values to be rearranged, N, is not positive.',
42     +    IER, 1)
43         RETURN
44      ENDIF
45C
46C     CHECK WHETHER IPERM IS A VALID PERMUTATION
47C
48      DO 100 I=1,N
49         INDX=ABS(IPERM(I))
50         IF((INDX.GE.1).AND.(INDX.LE.N))THEN
51            IF(IPERM(INDX).GT.0)THEN
52               IPERM(INDX)=-IPERM(INDX)
53               GOTO 100
54            ENDIF
55         ENDIF
56         IER=2
57         CALL XERMSG ('SLATEC', 'SPPERM',
58     +    'The permutation vector, IPERM, is not valid.', IER, 1)
59         RETURN
60  100 CONTINUE
61C
62C     REARRANGE THE VALUES OF X
63C
64C     USE THE IPERM VECTOR AS A FLAG.
65C     IF IPERM(I) > 0, THEN THE I-TH VALUE IS IN CORRECT LOCATION
66C
67      DO 330 ISTRT = 1 , N
68         IF (IPERM(ISTRT) .GT. 0) GOTO 330
69         INDX = ISTRT
70         INDX0 = INDX
71         TEMP = X(ISTRT)
72  320    CONTINUE
73         IF (IPERM(INDX) .GE. 0) GOTO 325
74            X(INDX) = X(-IPERM(INDX))
75            INDX0 = INDX
76            IPERM(INDX) = -IPERM(INDX)
77            INDX = IPERM(INDX)
78            GOTO 320
79  325    CONTINUE
80         X(INDX0) = TEMP
81  330 CONTINUE
82C
83      RETURN
84      END
85