Sources Esope | Cast3M

ordon1
C ORDON1    SOURCE    PV        21/01/21    21:15:29     10862          
      SUBROUTINE ORDON1 (IPLIST,CROISS,ABSOLU,IORDRE)
************************************************************************
*
*                             O R D O N 1
*                             -----------
*
* FONCTION:
* ---------
*
*     RANGER EN ORDRE CROISSANT OU DECROISSANT UN 'LISTREEL'.
*
* MODE D'APPEL:
* -------------
*
*     CALL ORDON1 (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 |  ORDM01  |  ORDM03  |     ABSO=F |  ORDO01  |  ORDO03  |
*   --------+----------+----------+    --------+----------+----------+
*    ABSO=V |  ORDM11  |  ORDM13  |     ABSO=V |  ORDO11  |  ORDO13  |
*   --------+----------+----------+    --------+----------+----------+
*
*
* 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 SMLREEL
-INC SMLENTI
-INC TMCOLAC
 
      pointeur piles.LISPIL
      pointeur jcolac.ICOLAC
      pointeur jlisse.ILISSE
      pointeur jtlacc.ITLACC
*
      iun=1
*
      MLREEL = IPLIST
      SEGACT,MLREEL
      LLIST = PROG(/1)
*
*     Preparation de la liste donnant le nouvel ordre de MLREEL
      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,MLREEL
         IF (IORDRE.NE.0) SEGDES,MLENT1
         RETURN
      END IF
*
*
*     ===========================
*     TRI PAR FUSION (MERGE SORT)
*     ===========================
*
      IF (LLIST.GT.100) THEN
          JG = (LLIST+1)/2
          SEGINI,MLREE2
*
          IF (IORDRE.EQ.0) THEN
              IF (ABSOLU) THEN
                  CALL ORDM11(PROG(1),LLIST,MLREE2.PROG(1),CROISS)
              ELSE
                  CALL ORDM01(PROG(1),LLIST,MLREE2.PROG(1),CROISS)
              END IF
          ELSE
              SEGINI,MLENT3
              IF (ABSOLU) THEN
                  CALL ORDM13(PROG(1),MLENT1.LECT(1),LLIST,
     &                        MLREE2.PROG(1),MLENT3.LECT(1),CROISS)
              ELSE
                  CALL ORDM03(PROG(1),MLENT1.LECT(1),LLIST,
     &                        MLREE2.PROG(1),MLENT3.LECT(1),CROISS)
              END IF
              SEGSUP,MLENT3
              SEGDES,MLENT1
          ENDIF
*
          SEGSUP,MLREE2
*
*
*     =================
*     TRI PAR INSERTION
*     =================
*
      ELSE
          IF (IORDRE.EQ.0) THEN
              IF (ABSOLU) THEN
                  CALL ORDO11(PROG(1),LLIST,CROISS)
              ELSE
                  CALL ORDO01(PROG(1),LLIST,CROISS)
              END IF
          ELSE
              IF (ABSOLU) THEN
                  CALL ORDO13(PROG(1),LLIST,CROISS,MLENT1.LECT(1))
              ELSE
                  CALL ORDO03(PROG(1),LLIST,CROISS,MLENT1.LECT(1))
              END IF
              SEGDES,MLENT1
          ENDIF
      ENDIF
*
*
      SEGDES,MLREEL
*
      IF(IPSAUV.NE.0) THEN
         ICOLAC = IPSAUV
         SEGACT ICOLAC
         ILISSE=ILISSG
         SEGACT ILISSE*MOD
         CALL TYPFIL('LISTREEL',ICO)
         ITLACC = KCOLA(ICO)
         SEGACT ITLACC*MOD
         CALL AJOUN0(ITLACC,MLREEL,ILISSE,iun)
         SEGDES ICOLAC,ILISSE
      ENDIF
C     Suppression des piles d'objets communiques
      if(piComm.gt.0) then
         piles=piComm
         segact piles
         call typfil('LISTREEL',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,MLREEL,jlisse,iun)
               segdes jtlacc
               segdes jlisse
               segdes jcolac
            endif
         enddo
         segdes piles
      endif
      RETURN
*
      END
*