myqsort_int.F

Go to the documentation of this file.

Copyright>        OpenRadioss
Copyright>        Copyright (C) 1986-2025 Altair Engineering Inc.
Copyright>
Copyright>        This program is free software: you can redistribute it and/or modify
Copyright>        it under the terms of the GNU Affero General Public License as published by
Copyright>        the Free Software Foundation, either version 3 of the License, or
Copyright>        (at your option) any later version.
Copyright>
Copyright>        This program is distributed in the hope that it will be useful,
Copyright>        but WITHOUT ANY WARRANTY; without even the implied warranty of
Copyright>        MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
Copyright>        GNU Affero General Public License for more details.
Copyright>
Copyright>        You should have received a copy of the GNU Affero General Public License
Copyright>        along with this program.  If not, see <https://www.gnu.org/licenses/>.
Copyright>
Copyright>
Copyright>        Commercial Alternative: Altair Radioss Software
Copyright>
Copyright>        As an alternative to this open-source version, Altair also offers Altair Radioss
Copyright>        software under a commercial license.  Contact Altair to discuss further if the
Copyright>        commercial version may interest you: https://www.altair.com/radioss/.
!||====================================================================
!||    myqsort_int                ../common_source/tools/sort/myqsort_int.F
!||--- called by ------------------------------------------------------
!||    find_surface_inter         ../engine/source/interfaces/interf/find_surface_inter.F
!||    get_segment_orientation    ../engine/source/interfaces/interf/get_segment_orientation.F90
!||    init_nodal_state           ../engine/source/interfaces/interf/init_nodal_state.F
!||    nloc_dmg_init              ../starter/source/materials/fail/nloc_dmg_init.F
!||    select_s2s                 ../starter/source/interfaces/inter3d1/select_s2s.F90
!||    spmd_cell_size_exchange    ../engine/source/mpi/interfaces/spmd_cell_size_exchange.F
!||    update_neighbour_segment   ../engine/source/interfaces/interf/update_neighbour_segment.F90
!||====================================================================
      SUBROUTINE myqsort_int(N, A, PERM, ERROR)
C-----------------------------------------------
c     q u i c k s o r t
C Sedgewick algorithm from "Implementing Quicksort Programs" ; int version
C     A: data
C     N: len
C     PERM: permutations
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER N,ERROR,PERM(N)
        INTEGER :: A(N)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER :: STACKLEN
        INTEGER :: TRESHOLD
        INTEGER :: DONE
C the max STACKLEN <= 1 + 2 x log2 (N+1)/(TRESHOLD + 2)
        parameter( stacklen = 128 ,
     .             treshold   =  9 )
C
        INTEGER :: I
        INTEGER :: IPLUS1
        INTEGER :: J
        INTEGER :: JMINUS1
        INTEGER :: K
        INTEGER :: LEFT
        INTEGER :: LLEN
        INTEGER :: RIGHT
        INTEGER :: RLEN
        INTEGER :: TOP
        INTEGER :: STACK(STACKLEN)
C     REAL ou REAL*8
        my_real
     .          rk, rv
C
        error = 0
C
        IF  (n < 1)  THEN
          error = -1
          RETURN
        ENDIF
 
        IF  (n == 1)  THEN
          perm(1)=1
          RETURN
        ENDIF
 
        DO  i = 1, n
          perm(i) = i
        ENDDO
C
        top = 1
        left = 1
        right = n
        IF (n <= treshold) THEN
          done = 1
        ELSE
          done = 0
        ENDIF
 
c     QUICKSORT
c
        DO WHILE (done /= 1)
          rk = a((left+right)/2)
          a((left+right)/2) = a(left)
          a(left) = rk
C
          k = perm((left+right)/2)
          perm((left+right)/2) = perm(left)
          perm(left) = k
 
          IF( a(left+1) > a(right) ) THEN
            rk = a(left+1)
            a(left+1) = a(right)
            a(right) = rk
            k = perm(left+1)
            perm(left+1) = perm(right)
            perm(right) = k
          ENDIF
          IF( a(left) > a(right) ) THEN
            rk = a(left)
            a(left) = a(right)
            a(right) = rk
            k = perm(left)
            perm(left) = perm(right)
            perm(right) = k
          ENDIF
          IF( a(left+1) >  a(left) ) THEN
            rk = a(left+1)
            a(left+1) = a(left)
            a(left) = rk
            k = perm(left+1)
            perm(left+1) = perm(left)
            perm(left) = k
          ENDIF
 
          rv = a(left)
          i = left+1
          j = right
 
          DO WHILE(j >= i)
            i  = i + 1
            DO WHILE(a(i) <  rv)
              i = i +1
            ENDDO
            j = j - 1
            DO WHILE(a(j) > rv)
              j = j - 1
            ENDDO
            IF (j >= i) THEN
              rk = a(i)
              a(i) = a(j)
              a(j) = rk
              k = perm(i)
              perm(i) = perm(j)
              perm(j) = k
            ENDIF
          ENDDO
C
          rk = a(left)
          a(left) = a(j)
          a(j) = rk
C
          k = perm(left)
          perm(left) = perm(j)
          perm(j) = k
C
          llen = j-left
          rlen = right - i + 1
 
          IF(max(llen, rlen) <= treshold ) THEN
            IF  (top == 1) THEN
              done = 1
            ELSE
              top = top - 2
              left = stack(top)
              right = stack(top+1)
            ENDIF
          ELSE IF(min(llen, rlen) <=  treshold) THEN
            IF( llen > rlen ) THEN
              right = j - 1
            ELSE
              left = i
            ENDIF
          ELSE
            IF( llen > rlen ) THEN
              stack(top) = left
              stack(top+1) = j-1
              left = i
            ELSE
              stack(top) = i
              stack(top+1) = right
              right = j-1
            ENDIF
            top = top + 2
          ENDIF
        END DO
c
c     INSERTION SORT
c
        i = n - 1
        iplus1 = n
        DO WHILE (i > 0)
          IF( a(i) > a(iplus1) ) THEN
            rk = a(i)
            k  = perm(i)
            j = iplus1
            jminus1 = i
            DO WHILE(a(j) <  rk)
              a(jminus1) = a(j)
              perm(jminus1) = perm(j)
              jminus1 = j
              j = j + 1
              IF  ( j > n )  EXIT
            ENDDO
            a(jminus1) = rk
            perm(jminus1) = k
          ENDIF
C
          iplus1 = i
          i = i - 1
        ENDDO
c
        RETURN
c
c     -------------------
c
      end