[u/mrichter/AliRoot.git] / HERWIG / src / hwusor.f


CDECK  ID>, HWUSOR.

*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber

*-- Author :    Adapted by Bryan Webber

C-----------------------------------------------------------------------

      SUBROUTINE HWUSOR(A,N,K,IOPT)

C-----------------------------------------------------------------------

C     Sort A(N) into ascending order

C     IOPT = 1 : return sorted A and index array K

C     IOPT = 2 : return index array K only

C-----------------------------------------------------------------------

      DOUBLE PRECISION A(N),B(500)

      INTEGER N,I,J,IOPT,K(N),IL(500),IR(500)

      IF (N.GT.500) CALL HWWARN('HWUSOR',100,*999)

      IL(1)=0

      IR(1)=0

      DO 10 I=2,N

      IL(I)=0

      IR(I)=0

      J=1

   2  IF(A(I).GT.A(J)) GOTO 5

   3  IF(IL(J).EQ.0) GOTO 4

      J=IL(J)

      GOTO 2

   4  IR(I)=-J

      IL(J)=I

      GOTO 10

   5  IF(IR(J).LE.0) GOTO 6

      J=IR(J)

      GOTO 2

   6  IR(I)=IR(J)

      IR(J)=I

  10  CONTINUE

      I=1

      J=1

      GOTO 8

  20  J=IL(J)

   8  IF(IL(J).GT.0) GOTO 20

   9  K(I)=J

      B(I)=A(J)

      I=I+1

      IF(IR(J)) 12,30,13

  13  J=IR(J)

      GOTO 8

  12  J=-IR(J)

      GOTO 9

  30  IF(IOPT.EQ.2) RETURN

      DO 31 I=1,N

  31  A(I)=B(I)

 999  END

CDECK  ID>, HWUSQR.

*CMZ :-        -26/04/91  11.11.56  by  Bryan Webber

*-- Author :    Bryan Webber

C-----------------------------------------------------------------------

      FUNCTION HWUSQR(X)

C-----------------------------------------------------------------------

C     SQUARE ROOT WITH SIGN RETENTION

C-----------------------------------------------------------------------

      DOUBLE PRECISION HWUSQR,X

      HWUSQR=SIGN(SQRT(ABS(X)),X)

      END
Commit	Line	Data
3820ca8e	1
	2	CDECK ID>, HWUSOR.
	3
	4	*CMZ :- -26/04/91 11.11.56 by Bryan Webber
	5
	6	*-- Author : Adapted by Bryan Webber
	7
	8	C-----------------------------------------------------------------------
	9
	10	SUBROUTINE HWUSOR(A,N,K,IOPT)
	11
	12	C-----------------------------------------------------------------------
	13
	14	C Sort A(N) into ascending order
	15
	16	C IOPT = 1 : return sorted A and index array K
	17
	18	C IOPT = 2 : return index array K only
	19
	20	C-----------------------------------------------------------------------
	21
	22	DOUBLE PRECISION A(N),B(500)
	23
	24	INTEGER N,I,J,IOPT,K(N),IL(500),IR(500)
	25
	26	IF (N.GT.500) CALL HWWARN('HWUSOR',100,*999)
	27
	28	IL(1)=0
	29
	30	IR(1)=0
	31
	32	DO 10 I=2,N
	33
	34	IL(I)=0
	35
	36	IR(I)=0
	37
	38	J=1
	39
	40	2 IF(A(I).GT.A(J)) GOTO 5
	41
	42	3 IF(IL(J).EQ.0) GOTO 4
	43
	44	J=IL(J)
	45
	46	GOTO 2
	47
	48	4 IR(I)=-J
	49
	50	IL(J)=I
	51
	52	GOTO 10
	53
	54	5 IF(IR(J).LE.0) GOTO 6
	55
	56	J=IR(J)
	57
	58	GOTO 2
	59
	60	6 IR(I)=IR(J)
	61
	62	IR(J)=I
	63
	64	10 CONTINUE
65
66	I=1
67
68	J=1
69
70	GOTO 8
71
72	20 J=IL(J)
73
74	8 IF(IL(J).GT.0) GOTO 20
75
76	9 K(I)=J
77
78	B(I)=A(J)
79
80	I=I+1
81
82	IF(IR(J)) 12,30,13
83
84	13 J=IR(J)
85
86	GOTO 8
87
88	12 J=-IR(J)
89
90	GOTO 9
91
92	30 IF(IOPT.EQ.2) RETURN
93
94	DO 31 I=1,N
95
96	31 A(I)=B(I)
97
98	999 END
99
100	CDECK ID>, HWUSQR.
101
102	*CMZ :- -26/04/91 11.11.56 by Bryan Webber
103
104	*-- Author : Bryan Webber
105
106	C-----------------------------------------------------------------------
107
108	FUNCTION HWUSQR(X)
109
110	C-----------------------------------------------------------------------
111
112	C SQUARE ROOT WITH SIGN RETENTION
113
114	C-----------------------------------------------------------------------
115
116	DOUBLE PRECISION HWUSQR,X
117
118	HWUSQR=SIGN(SQRT(ABS(X)),X)
119
120	END