mirror of
https://code.it4i.cz/sccs/easyconfigs-it4i.git
synced 2025-04-17 12:10:50 +01:00
196 lines
3.7 KiB
Fortran
Executable File
196 lines
3.7 KiB
Fortran
Executable File
SUBROUTINE QSORTI (ORD,N,A,m)
|
|
C
|
|
C==============SORTS THE ARRAY A(I),I=1,2,...,N BY PUTTING THE
|
|
C ASCENDING ORDER VECTOR IN ORD. THAT IS ASCENDING ORDERED A
|
|
C IS A(ORD(I)),I=1,2,...,N; DESCENDING ORDER A IS A(ORD(N-I+1)),
|
|
C I=1,2,...,N . THIS SORT RUNS IN TIME PROPORTIONAL TO N LOG N .
|
|
C
|
|
C
|
|
IMPLICIT INTEGER (A-Z)
|
|
C
|
|
DIMENSION ORD(N),POPLST(2,20)
|
|
C
|
|
C TO SORT DIFFERENT INPUT TYPES, CHANGE THE FOLLOWING
|
|
C SPECIFICATION STATEMENTS; FOR EXAMPLE, FOR FORTRAN CHARACTER
|
|
C USE THE FOLLOWING: CHARACTER *(*) A(N)
|
|
C
|
|
INTEGER X(m),XX(m),Z(m),ZZ(m),Y(m)
|
|
INTEGER A(m,N)
|
|
logical qle,qge,qne
|
|
C
|
|
NDEEP=0
|
|
U1=N
|
|
L1=1
|
|
DO 1 I=1,N
|
|
1 ORD(I)=I
|
|
2 IF (U1.LE.L1) RETURN
|
|
C
|
|
3 L=L1
|
|
U=U1
|
|
C
|
|
C PART
|
|
C
|
|
4 P=L
|
|
Q=U
|
|
C FOR CHARACTER SORTS, THE FOLLOWING 3 STATEMENTS WOULD BECOME
|
|
C X = ORD(P)
|
|
C Z = ORD(Q)
|
|
C IF (A(X) .LE. A(Z)) GO TO 2
|
|
C
|
|
C WHERE "CLE" IS A LOGICAL FUNCTION WHICH RETURNS "TRUE" IF THE
|
|
C FIRST ARGUMENT IS LESS THAN OR EQUAL TO THE SECOND, BASED ON "LEN"
|
|
C CHARACTERS.
|
|
C
|
|
call qes(x,a(1,ord(p)),m)
|
|
call qes(z,a(1,ord(q)),m)
|
|
IF (qle(X,Z,m)) GO TO 5
|
|
call qes(y,x,m)
|
|
call qes(x,z,m)
|
|
call qes(z,y,m)
|
|
YP=ORD(P)
|
|
ORD(P)=ORD(Q)
|
|
ORD(Q)=YP
|
|
5 IF (U-L.LE.1) GO TO 15
|
|
call qes(xx,x,m)
|
|
IX=P
|
|
call qes(zz,z,m)
|
|
IZ=Q
|
|
C
|
|
C LEFT
|
|
C
|
|
6 P=P+1
|
|
IF (P.GE.Q) GO TO 7
|
|
call qes(x,a(1,ord(p)),m)
|
|
IF (qge(X,XX,m)) GO TO 8
|
|
GO TO 6
|
|
7 P=Q-1
|
|
GO TO 13
|
|
C
|
|
C RIGHT
|
|
C
|
|
8 Q=Q-1
|
|
IF (Q.LE.P) GO TO 9
|
|
call qes(z,a(1,ord(q)),m)
|
|
IF (qle(Z,ZZ,m)) GO TO 10
|
|
GO TO 8
|
|
9 Q=P
|
|
P=P-1
|
|
call qes(z,x,m)
|
|
call qes(x,a(1,ord(p)),m)
|
|
C
|
|
C DIST
|
|
C
|
|
10 IF (qle(X,Z,m)) GO TO 11
|
|
call qes(y,x,m)
|
|
call qes(x,z,m)
|
|
call qes(z,y,m)
|
|
IP=ORD(P)
|
|
ORD(P)=ORD(Q)
|
|
ORD(Q)=IP
|
|
11 IF (qle(X,XX,m)) GO TO 12
|
|
call qes(xx,x,m)
|
|
IX=P
|
|
12 IF (qge(Z,ZZ,m)) GO TO 6
|
|
call qes(zz,z,m)
|
|
IZ=Q
|
|
GO TO 6
|
|
C
|
|
C OUT
|
|
C
|
|
13 CONTINUE
|
|
IF (.NOT.(P.NE.IX.AND.qne(X,XX,m))) GO TO 14
|
|
IP=ORD(P)
|
|
ORD(P)=ORD(IX)
|
|
ORD(IX)=IP
|
|
14 CONTINUE
|
|
IF (.NOT.(Q.NE.IZ.AND.qne(Z,ZZ,m))) GO TO 15
|
|
IQ=ORD(Q)
|
|
ORD(Q)=ORD(IZ)
|
|
ORD(IZ)=IQ
|
|
15 CONTINUE
|
|
IF (U-Q.LE.P-L) GO TO 16
|
|
L1=L
|
|
U1=P-1
|
|
L=Q+1
|
|
GO TO 17
|
|
16 U1=U
|
|
L1=Q+1
|
|
U=P-1
|
|
17 CONTINUE
|
|
IF (U1.LE.L1) GO TO 18
|
|
C
|
|
C START RECURSIVE CALL
|
|
C
|
|
NDEEP=NDEEP+1
|
|
POPLST(1,NDEEP)=U
|
|
POPLST(2,NDEEP)=L
|
|
GO TO 3
|
|
18 IF (U.GT.L) GO TO 4
|
|
C
|
|
C POP BACK UP IN THE RECURSION LIST
|
|
C
|
|
IF (NDEEP.EQ.0) GO TO 2
|
|
U=POPLST(1,NDEEP)
|
|
L=POPLST(2,NDEEP)
|
|
NDEEP=NDEEP-1
|
|
GO TO 18
|
|
C
|
|
C END SORT
|
|
C END QSORT
|
|
C
|
|
END
|
|
C
|
|
subroutine qes(x,y,m)
|
|
implicit none
|
|
integer m,x(m),y(m),i
|
|
do i=1,m
|
|
x(i)=y(i)
|
|
enddo
|
|
return
|
|
end
|
|
C
|
|
logical function qle(x,y,m)
|
|
implicit none
|
|
integer m,x(m),y(m),i
|
|
i=1
|
|
do while(x(i).eq.y(i).and.i.lt.m)
|
|
i=i+1
|
|
enddo
|
|
if(x(i).le.y(i)) then
|
|
qle=.true.
|
|
else
|
|
qle=.false.
|
|
endif
|
|
return
|
|
end
|
|
C
|
|
logical function qge(x,y,m)
|
|
implicit none
|
|
integer m,x(m),y(m),i
|
|
i=1
|
|
do while(x(i).eq.y(i).and.i.lt.m)
|
|
i=i+1
|
|
enddo
|
|
if(x(i).ge.y(i)) then
|
|
qge=.true.
|
|
else
|
|
qge=.false.
|
|
endif
|
|
return
|
|
end
|
|
C
|
|
logical function qne(x,y,m)
|
|
implicit none
|
|
integer m,x(m),y(m),i
|
|
i=1
|
|
do while(x(i).eq.y(i).and.i.lt.m)
|
|
i=i+1
|
|
enddo
|
|
if(x(i).ne.y(i)) then
|
|
qne=.true.
|
|
else
|
|
qne=.false.
|
|
endif
|
|
return
|
|
end
|