Sources Esope | Cast3M

ordon2
C ORDON2    SOURCE    PV        21/01/21    21:15:30     10862          
      SUBROUTINE ORDON2 (IPLIST,CROISS,ABSOLU,IORDRE)
************************************************************************
*
*                             O R D O N 2
*                             -----------
*
* FONCTION:
* ---------
*
*     RANGER EN ORDRE CROISSANT OU DECROISSANT UN 'LISTENTI'.
*
* MODE D'APPEL:
* -------------
*
*     CALL ORDON2 (IPLIST,CROISS,ABSOLU)
*
* PARAMETRES:   (E)=ENTREE   (S)=SORTIE
* -----------
*
*     IPLIST  ENTIER    (E)  POINTEUR SUR LA LISTE A ORDONNER.
*                       (S)  MEME POINTEUR, LISTE REORDONNEE.
*     CROISS  LOGIQUE   (E)  INDIQUE PAR "VRAI" OU "FAUX" SI ON ORDONNE
*                            CROISSANT OU NON.
*     ABSOLU  LOGIQUE   (E)  INDIQUE PAR "VRAI" OU "FAUX" SI ON ORDONNE
*                            EN CONSIDERANT LES VALEURS ABSOLUES OU LES
*                            VRAIES VALEURS.
*     IORDRE  ENTIER    (E)  SI NON NUL, INDIQUE QUE L'ON SOUHAITE
*                            RENVOYER LE NOUVEL ORDRE DE LA LISTE
*                       (S)  POINTEUR VERS UN LISTENTI CONTENANT LE
*                            NOUVEL ORDRE DES ELEMENTS
*
* SOUS-PROGRAMMES APPELES:
* ------------------------
*
*               TRI PAR FUSION                    TRI PAR INSERTION
*
*           | IORDRE=0 | IORDRE#0 |            | IORDRE=0 | IORDRE#0 |
*   --------+----------+----------+    --------+----------+----------+
*    ABSO=F |  ORDM02  |  ORDM04  |     ABSO=F |  ORDO04  |  ORDO04  |
*   --------+----------+----------+    --------+----------+----------+
*    ABSO=V |  ORDM12  |  ORDM14  |     ABSO=V |  ORDO14  |  ORDO14  |
*   --------+----------+----------+    --------+----------+----------+
*
*
* AUTEUR, DATE DE CREATION:
* -------------------------
*
*     PASCAL MANIGOT     19 MARS 1985
*
*     OPTION "ABSOLU" AJOUTEE LE 23 AVRIL 1985 (P. MANIGOT)
*
*     OPTION "IORDRE" AJOUTEE LE 10 DEC 2014 (JCARDO)
*
* LANGAGE:
* --------
*
*     ESOPE + FORTRAN77
*
************************************************************************
*
      IMPLICIT INTEGER(I-N)
      LOGICAL CROISS,ABSOLU
      integer ICO, IPILE, IPLIST, LLIST
 
-INC PPARAM
-INC CCOPTIO
-INC COCOLL
-INC SMLENTI
-INC TMCOLAC
 
      pointeur piles.LISPIL
      pointeur jcolac.ICOLAC
      pointeur jlisse.ILISSE
      pointeur jtlacc.ITLACC
*
      iun=1
*
      MLENTI = IPLIST
      SEGACT,MLENTI
      LLIST = LECT(/1)
*
*     Preparation de la liste donnant le nouvel ordre de MLENTI
      IF (IORDRE.NE.0) THEN
          JG = LLIST
          SEGINI,MLENT1
          IORDRE=MLENT1
          DO I=1,LLIST
              MLENT1.LECT(I)=I
          ENDDO
      ENDIF
*
      IF (LLIST.LE.1) THEN
         SEGDES,MLENTI
         IF (IORDRE.NE.0) SEGDES,MLENT1
         RETURN
      END IF
*
*
*     ===========================
*     TRI PAR FUSION (MERGE SORT)
*     ===========================
*
      IF (LLIST.GT.100) THEN
          JG = (LLIST+1)/2
          SEGINI,MLENT2
*
          IF (IORDRE.EQ.0) THEN
              IF (ABSOLU) THEN
                  CALL ORDM12(LECT(1),LLIST,MLENT2.LECT(1),CROISS)
              ELSE
                  CALL ORDM02(LECT(1),LLIST,MLENT2.LECT(1),CROISS)
              END IF
          ELSE
              SEGINI,MLENT3
              IF (ABSOLU) THEN
                  CALL ORDM14(LECT(1),MLENT1.LECT(1),LLIST,
     &                        MLENT2.LECT(1),MLENT3.LECT(1),CROISS)
              ELSE
                  CALL ORDM04(LECT(1),MLENT1.LECT(1),LLIST,
     &                        MLENT2.LECT(1),MLENT3.LECT(1),CROISS)
              END IF
              SEGSUP,MLENT3
              SEGDES,MLENT1
          ENDIF
*
          SEGSUP,MLENT2
*
*
*     =================
*     TRI PAR INSERTION
*     =================
*
      ELSE
          IF (IORDRE.EQ.0) THEN
              IF (ABSOLU) THEN
                  CALL ORDO12(LECT(1),LLIST,CROISS)
              ELSE
                  CALL ORDO02(LECT(1),LLIST,CROISS)
              END IF
          ELSE
              IF (ABSOLU) THEN
                  CALL ORDO14(LECT(1),LLIST,CROISS,MLENT1.LECT(1))
              ELSE
                  CALL ORDO04(LECT(1),LLIST,CROISS,MLENT1.LECT(1))
              END IF
              SEGDES,MLENT1
          ENDIF
      ENDIF
*
*
      SEGDES,MLENTI
      IF(IPSAUV.NE.0) THEN
        ICOLAC = IPSAUV
        SEGACT ICOLAC
        ILISSE=ILISSG
        SEGACT ILISSE*MOD
        CALL TYPFIL('LISTENTI',ICO)
        ITLACC = KCOLA(ICO)
        SEGACT ITLACC*MOD
        CALL AJOUN0(ITLACC,MLENTI,ILISSE,iun)
        SEGDES ICOLAC,ILISSE
      ENDIF
C     Suppression des piles d'objets communiques
      if(piComm.gt.0) then
         piles=piComm
         segact piles
         call typfil('LISTENTI',ico)
         do ipile=1,piles.proc(/1)
            jcolac= piles.proc(ipile)
            if(jcolac.ne.0) then
               segact jcolac
               jlisse=jcolac.ilissg
               segact jlisse*mod
               jtlacc=jcolac.kcola(ico)
               segact jtlacc*mod
               call ajoun0(jtlacc,MLENTI,jlisse,iun)
               segdes jtlacc
               segdes jlisse
               segdes jcolac
            endif
         enddo
         segdes piles
      endif
*
      RETURN
*
      END