iparti.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/.
!||====================================================================
!||    iparti   ../common_source/tools/sort/iparti.F
!||--- called by ------------------------------------------------------
!||    trirap   ../common_source/tools/sort/trirap.F
!||--- calls      -----------------------------------------------------
!||    echang   ../common_source/tools/sort/echang.F
!||    icompc   ../common_source/tools/sort/icompc.F
!||====================================================================
      INTEGER FUNCTION iparti(I,J,TAB,N2)
C-----------------------------------------------
C   I m p l i c i t   T y p e s
C-----------------------------------------------
#include      "implicit_f.inc"
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
        INTEGER i, j, n2
C     REAL
        my_real
     .     tab(*)
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
        INTEGER milieu, u, v
C-----------------------------------------------
C   E x t e r n a l   F u n c t i o n s
C-----------------------------------------------
        INTEGER icompc
        iparti=i
        IF(j>i) THEN
          milieu=(i+j)/2
          u=i
          v=j+1
C
          IF(icompc(j,milieu,tab)<0) THEN
            CALL echang(j,milieu,tab)
            CALL echang(n2+j,n2+milieu,tab)
          ENDIF
          IF(icompc(j,i,tab)<0) THEN
            CALL echang(j,i,tab)
            CALL echang(n2+j,n2+i,tab)
          ENDIF
          IF(icompc(i,milieu,tab)<0) THEN
            CALL echang(i,milieu,tab)
            CALL echang(n2+i,n2+milieu,tab)
          ENDIF
C
 1000     IF(u<v) THEN
C
 1100       CONTINUE
            u=u+1
            IF(icompc(u,i,tab)<0) GO TO 1100
C
 1200       CONTINUE
            v=v-1
            IF(icompc(v,i,tab)>0) GO TO 1200
C
            CALL echang(u,v,tab)
            CALL echang(n2+u,n2+v,tab)
            GO TO 1000
          ENDIF
          IF(u>v) CALL echang(u,v,tab)
          IF(u>v) CALL echang(n2+u,n2+v,tab)
          u=min0(u,v)
          CALL echang(i,u,tab)
          CALL echang(n2+i,n2+u,tab)
          iparti=u
        ENDIF
        RETURN
      END