mirror of
https://git.planet-casio.com/Lephenixnoir/OpenLibm.git
synced 2025-01-01 06:23:39 +01:00
95 lines
3 KiB
Fortran
95 lines
3 KiB
Fortran
*DECK HPPERM
|
|
SUBROUTINE HPPERM (HX, N, IPERM, WORK, IER)
|
|
C***BEGIN PROLOGUE HPPERM
|
|
C***PURPOSE Rearrange a given array according to a prescribed
|
|
C permutation vector.
|
|
C***LIBRARY SLATEC
|
|
C***CATEGORY N8
|
|
C***TYPE CHARACTER (SPPERM-S, DPPERM-D, IPPERM-I, HPPERM-H)
|
|
C***KEYWORDS APPLICATION OF PERMUTATION TO DATA VECTOR
|
|
C***AUTHOR McClain, M. A., (NIST)
|
|
C Rhoads, G. S., (NBS)
|
|
C***DESCRIPTION
|
|
C
|
|
C HPPERM rearranges the data vector HX according to the
|
|
C permutation IPERM: HX(I) <--- HX(IPERM(I)). IPERM could come
|
|
C from one of the sorting routines IPSORT, SPSORT, DPSORT or
|
|
C HPSORT.
|
|
C
|
|
C Description of Parameters
|
|
C HX - input/output -- character array of values to be
|
|
C rearranged.
|
|
C N - input -- number of values in character array HX.
|
|
C IPERM - input -- permutation vector.
|
|
C WORK - character variable which must have a length
|
|
C specification at least as great as that of HX.
|
|
C IER - output -- error indicator:
|
|
C = 0 if no error,
|
|
C = 1 if N is zero or negative,
|
|
C = 2 if work array is not long enough,
|
|
C = 3 if IPERM is not a valid permutation.
|
|
C
|
|
C***REFERENCES (NONE)
|
|
C***ROUTINES CALLED XERMSG
|
|
C***REVISION HISTORY (YYMMDD)
|
|
C 901004 DATE WRITTEN
|
|
C 920507 Modified by M. McClain to revise prologue text and to add
|
|
C check for length of work array.
|
|
C***END PROLOGUE HPPERM
|
|
INTEGER N, IPERM(*), I, IER, INDX, INDX0, ISTRT
|
|
CHARACTER*(*) HX(*), WORK
|
|
C***FIRST EXECUTABLE STATEMENT HPPERM
|
|
IER=0
|
|
IF(N.LT.1)THEN
|
|
IER=1
|
|
CALL XERMSG ('SLATEC', 'HPPERM',
|
|
+ 'The number of values to be rearranged, N, is not positive.',
|
|
+ IER, 1)
|
|
RETURN
|
|
ENDIF
|
|
IF(LEN(WORK).LT.LEN(HX(1)))THEN
|
|
IER=2
|
|
CALL XERMSG ('SLATEC', 'HPPERM',
|
|
+ 'The length of the work variable, WORK, is too short.',IER,1)
|
|
RETURN
|
|
ENDIF
|
|
C
|
|
C CHECK WHETHER IPERM IS A VALID PERMUTATION
|
|
C
|
|
DO 100 I=1,N
|
|
INDX=ABS(IPERM(I))
|
|
IF((INDX.GE.1).AND.(INDX.LE.N))THEN
|
|
IF(IPERM(INDX).GT.0)THEN
|
|
IPERM(INDX)=-IPERM(INDX)
|
|
GOTO 100
|
|
ENDIF
|
|
ENDIF
|
|
IER=3
|
|
CALL XERMSG ('SLATEC', 'HPPERM',
|
|
+ 'The permutation vector, IPERM, is not valid.', IER, 1)
|
|
RETURN
|
|
100 CONTINUE
|
|
C
|
|
C REARRANGE THE VALUES OF HX
|
|
C
|
|
C USE THE IPERM VECTOR AS A FLAG.
|
|
C IF IPERM(I) > 0, THEN THE I-TH VALUE IS IN CORRECT LOCATION
|
|
C
|
|
DO 330 ISTRT = 1 , N
|
|
IF (IPERM(ISTRT) .GT. 0) GOTO 330
|
|
INDX = ISTRT
|
|
INDX0 = INDX
|
|
WORK = HX(ISTRT)
|
|
320 CONTINUE
|
|
IF (IPERM(INDX) .GE. 0) GOTO 325
|
|
HX(INDX) = HX(-IPERM(INDX))
|
|
INDX0 = INDX
|
|
IPERM(INDX) = -IPERM(INDX)
|
|
INDX = IPERM(INDX)
|
|
GOTO 320
|
|
325 CONTINUE
|
|
HX(INDX0) = WORK
|
|
330 CONTINUE
|
|
C
|
|
RETURN
|
|
END
|