qsortc.F

Go to the documentation of this file.

! Sort character strings
      SUBROUTINE qsortc (N,ORD,A)
      USE parkind1, ONLY : jpim
!      IMPLICIT INTEGER (A-Z)
      IMPLICIT NONE
      
      INTEGER(KIND=JPIM) :: N
      INTEGER(KIND=JPIM) :: ORD(n)
      INTEGER(KIND=JPIM) :: I,IP,IQ,IX,IZ,L,L1,NDEEP,P
      INTEGER(KIND=JPIM) :: POPLST(2,20)
      INTEGER(KIND=JPIM) :: Q,U,U1,YP

      CHARACTER(LEN=*) :: A(n)
      CHARACTER(LEN=LEN(A)) :: X,XX,Z,ZZ,Y

      ndeep=0
      u1=n
      l1=1
      DO 1  i=1,n
    1 ord(i)=i
    2 IF (u1.LE.l1) RETURN

    3 l=l1
      u=u1
    4 p=l
      q=u

      x=a(ord(p))
      z=a(ord(q))
      IF (x.LE.z) GO TO 5
      y=x
      x=z
      z=y
      yp=ord(p)
      ord(p)=ord(q)
      ord(q)=yp
    5 IF (u-l.LE.1) GO TO 15
      xx=x
      ix=p
      zz=z
      iz=q

    6 p=p+1
      IF (p.GE.q) GO TO 7
      x=a(ord(p))
      IF (x.GE.xx) GO TO 8
      GO TO 6
    7 p=q-1
      GO TO 13

    8 q=q-1
      IF (q.LE.p) GO TO 9
      z=a(ord(q))
      IF (z.LE.zz) GO TO 10
      GO TO 8
    9 q=p
      p=p-1
      z=x
      x=a(ord(p))

   10 IF (x.LE.z) GO TO 11
      y=x
      x=z
      z=y
      ip=ord(p)
      ord(p)=ord(q)
      ord(q)=ip
   11 IF (x.LE.xx) GO TO 12
      xx=x
      ix=p
   12 IF (z.GE.zz) GO TO 6
      zz=z
      iz=q
      GO TO 6

   13 CONTINUE
      IF (.NOT.(p.NE.ix.AND.x.NE.xx)) GO TO 14
      ip=ord(p)
      ord(p)=ord(ix)
      ord(ix)=ip
   14 CONTINUE
      IF (.NOT.(q.NE.iz.AND.z.NE.zz)) 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

      ndeep=ndeep+1
      poplst(1,ndeep)=u
      poplst(2,ndeep)=l
      GO TO 3
   18 IF (u.GT.l) GO TO 4

      IF (ndeep.EQ.0) GO TO 2
      u=poplst(1,ndeep)
      l=poplst(2,ndeep)
      ndeep=ndeep-1
      GO TO 18

      ENDSUBROUTINE qsortc