C ORDONN    SOURCE    JC220346  12/10/09    21:15:10     7524           
      SUBROUTINE ORDONN
************************************************************************
*
*                             O R D O N N
*                             -----------
*
*            SOUS-PROGRAMME ASSOCIE A LA DIRECTIVE "ORDONNER"
*
* FONCTION:
* ---------
*
*     RANGER EN ORDRE CROISSANT OU DECROISSANT LE CONTENU D'UNE LISTE
*     ORDONNABLE.
*     "CROISSANT" EST L'OPTION PAR DEFAUT.
*
* PHRASE D'APPEL (EN GIBIANE):
* ----------------------------
*
* OBJ1 (OBJ3) = ORDONNER |(CROISSANT)  | (ABSOLU) (UNIQUE) OBJ2 (OBJ4) ;
*                        |(DECROISSANT)|
*
*     LES PARENTHESES INDIQUANT DES OPERANDES FACULTATIFS.
*
* OPERANDES ET RESULTATS:
* -----------------------
*
*     CROISSAN  'MOT     '  MOT-CLE INDIQUANT QUE L'ON RANGE LE CONTENU
*                           DE L'OBJET "LL" EN ORDRE CROISSANT.
*
*     DECROISS  'MOT     '  MOT-CLE INDIQUANT QUE L'ON RANGE LE CONTENU
*                           DE L'OBJET "LL" EN ORDRE DECROISSANT.
*
*     ABSOLU    'MOT     '  MOT-CLE INDIQUANT QUE L'ON NE TIENT COMPTE
*                           QUE DES VALEURS ABSOLUES DES NOMBRES DE
*                           L'OBJET POUR FAIRE LA MISE EN ORDRE.
*
*     UNIQUE    'MOT     '  MOT-CLE INDIQUANT QUE LES DOUBLONS SONT
*                           SUPPRIMES.
*
*     OBJ1      'LISTREEL'  OBJET QUE L'ON VEUT ORDONNER.
*            OU 'LISTENTI'
*            OU 'EVOLUTIO'
*            OU 'MAILLAGE'
*
*    (OBJ2)     'LISTREEL'  OBJET SUBISSANT LA MEME PERMUTATION QUE OBJ1
*            OU 'LISTENTI'  (DANS CE CAS, OBJ1 EST UN LISTENTI OU UN
*                           LISTREEL ET L'OPTION UNIQUE EST INACTIVE)
*
* SOUS-PROGRAMMES APPELES:
* ------------------------
*
*     LIRMOT, LIRTYP, ORDON1, ORDON2, ORDON3 ,ORDON4
*
* AUTEUR, DATE DE CREATION:
* -------------------------
*
*     PASCAL MANIGOT     19 MARS 1985
*
*     OPTION "ABSOLU" AJOUTEE LE 23 AVRIL 1985 (P. MANIGOT)
*
*     JCARDO 11/09/2012 => ORDO PASSE DE DIRECTIVE A OPERATEUR
*
* LANGAGE:
* --------
*
*     FORTRAN77 + EXTENSION: CARACTERES MIS DANS DES ENTIERS
*
************************************************************************
*
      IMPLICIT INTEGER(I-N)
      REAL*8 x1,x2
-INC CCOPTIO
-INC SMLREEL
-INC SMLENTI
-INC SMEVOLL
-INC SMELEME
-INC CCREEL
*
      PARAMETER (NBRTYP = 4)
      PARAMETER (NBMOTS = 4 , NBOPT = 2)
*
      CHARACTER*8 LISTYP(NBRTYP),MONTYP
      CHARACTER*4 LISMOT(NBMOTS)
*
      LOGICAL CROISS,ABSOLU,STRICT
*
      DATA LISTYP/'LISTREEL','LISTENTI','EVOLUTIO','MAILLAGE'/
      DATA LISMOT/'CROI','DECR','ABSO','UNIQ'/
*
      CROISS = .TRUE.
      ABSOLU = .FALSE.
      STRICT = .FALSE.
*
      DO 100 IB100=1,NBOPT
         ICODE = 0
         NBMOT = NBMOTS
         CALL LIRMOT (LISMOT,NBMOT,NUMMOT,ICODE)
         IF (IERR .NE. 0) RETURN
         IF (NUMMOT .EQ. 0) THEN
*           --> SORTIE DE BOUCLE N.100
            GOTO 102
         ELSE IF (NUMMOT .EQ. 1) THEN
            CROISS = .TRUE.
         ELSE IF (NUMMOT .EQ. 2) THEN
            CROISS = .FALSE.
         ELSE IF (NUMMOT .EQ. 3) THEN
            ABSOLU = .TRUE.
         ELSE IF (NUMMOT .EQ. 4) THEN
            STRICT = .TRUE.
         END IF
  100    CONTINUE
*     END DO
  102 CONTINUE
*
      ICODE = 1
      NBTYP = NBRTYP
      CALL QUETYP(MONTYP,0    ,IRETOU)
      IF (IRETOU.EQ.0) THEN
         CALL ERREUR(533)
         RETURN
      ENDIF
      DO 10 NUMLIS=1,NBTYP
       IF (MONTYP.EQ.LISTYP(NUMLIS))  GOTO 11
  10  CONTINUE
      MOTERR(1:8)=MONTYP
      CALL ERREUR(39)
      RETURN
  11  CONTINUE
      CALL LIROBJ(MONTYP,IPLIST,ICODE,IRETOU)
      IF (IERR .NE. 0) RETURN
      CALL LIROBJ(MONTYP,IPLI2,0,IRET2)
      IF (IERR .NE. 0) RETURN
*
*     +-----------------------------------------------------+
*     |             O B J E T   L I S T R E E L             |
*     +-----------------------------------------------------+
*
      IF (NUMLIS .EQ. 1) THEN
*
*         DEUX OBJETS LISTREEL ONT ETE FOURNIS
*         *************************************************
          IF (IRET2.NE.0) THEN
C               MLREEL = IPLIST
C               MLREE1 = IPLI2
C               SEGACT MLREEL*MOD,MLREE1*MOD
              MLREE2 = IPLIST
              MLREE3 = IPLI2
              SEGACT,MLREE2,MLREE3
              SEGINI,MLREEL=MLREE2,MLREE1=MLREE3
              SEGDES,MLREE2,MLREE3
*
              IF (PROG(/1).GT.MLREE1.PROG(/1)) THEN
                  SEGDES,MLREEL,MLREE1
c la seconde suite doit être au moins aussi longue
                  CALL ERREUR(3)
                  RETURN
              ENDIF
              JG = PROG(/1)
              NT1 = JG
              SEGINI,MLREE2
              JG = MLREE1.PROG(/1)
              SEGINI,MLREE3
              IF (ABSOLU) THEN
                  DO IV = 1,JG
                      MLREEL.PROG(IV) = DABS(MLREEL.PROG(IV))
                  ENDDO
                  DO IV = 1,JG
                      MLREE1.PROG(IV) = DABS(MLREE1.PROG(IV))
                  ENDDO
              ENDIF
              CALL TRIFL2(MLREEL.PROG(1),MLREE2.PROG(1),
     &                    MLREE1.PROG(1),MLREE3.PROG(1),NT1)
              IF (.NOT.CROISS) THEN
                  DO IV = 1,JG
                      MLREE2.PROG(IV) = PROG(IV)
                      MLREE3.PROG(IV) = MLREE1.PROG(IV)
                  ENDDO
                  DO IV = 1,JG
                      PROG(IV) = MLREE2.PROG(JG + 1 - IV)
                      MLREE1.PROG(IV) = MLREE3.PROG(JG + 1 - IV)
                  ENDDO
              ENDIF
              SEGSUP,MLREE2,MLREE3
              SEGDES,MLREEL,MLREE1
*
              CALL ECROBJ('LISTREEL',MLREE1)
              CALL ECROBJ('LISTREEL',MLREEL)
*
*         DEUX OBJETS LISTREEL + LISTENTI ONT ETE FOURNIS
*         *************************************************
          ELSE
              CALL LIROBJ('LISTENTI',IPLI2,0,IRET2)
              IF (IERR .NE. 0) RETURN
              IF (IRET2.NE.0) THEN
C                   MLREEL = IPLIST
C                   MLENTI = IPLI2
C                   SEGACT MLREEL*MOD,MLENTI*MOD
                  MLREE1 = IPLIST
                  MLENT1 = IPLI2
                  SEGACT,MLREE1,MLENT1
                  SEGINI,MLREEL=MLREE1,MLENTI=MLENT1
                  SEGDES,MLREE1,MLENT1
*
                  IF (PROG(/1).GT.LECT(/1)) THEN
                      SEGDES,MLREEL,MLENTI
c la seconde suite doit être au moins aussi longue
                      CALL ERREUR(3)
                      RETURN
                  ENDIF
                  JG = PROG(/1)
                  NT1 = JG
                  SEGINI,MLREE2
                  JG = LECT(/1)
                  SEGINI,MLENT3
                  IF (ABSOLU) THEN
                      DO IV = 1,JG
                          MLREEL.PROG(IV) = DABS(MLREEL.PROG(IV))
                      ENDDO
                      DO IV = 1,JG
                          LECT(IV) = ABS(LECT(IV))
                      ENDDO
                  ENDIF
                  CALL TRIFLO(MLREEL.PROG(1),MLREE2.PROG(1),
     &                        LECT(1),MLENT3.LECT(1),NT1)
                  IF (.NOT.CROISS) THEN
                      DO IV = 1,JG
                          MLREE2.PROG(IV) = PROG(IV)
                          MLENT3.LECT(IV) = LECT(IV)
                      ENDDO
                      DO IV = 1,JG
                          PROG(IV) = MLREE2.PROG(JG + 1 - IV)
                          LECT(IV) = MLENT3.LECT(JG + 1 - IV)
                      ENDDO
                  ENDIF
                  SEGSUP,MLREE2,MLENT3
                  SEGDES,MLREEL, MLENTI
*
                  CALL ECROBJ('LISTENTI',MLENTI)
                  CALL ECROBJ('LISTREEL',MLREEL)
*
*         UN SEUL OBJET LISTREEL A ETE FOURNI
*         *************************************************
              ELSE
                  MLREE1 = IPLIST
                  SEGACT,MLREE1
                  SEGINI,MLREEL=MLREE1
                  SEGDES,MLREE1
                  IPLIST = MLREEL
*
                  CALL ORDON1 (IPLIST,CROISS,ABSOLU)
*
                  IF (STRICT) THEN
                      MLREE1 = IPLIST
                      SEGACT,MLREE1
                      JG = MLREE1.PROG(/1)
                      IF (JG.EQ.0) GOTO 20
                      SEGINI,MLREEL
                      PROG(1) = MLREE1.PROG(1)
                      X1 = PROG(1)
                      LL = 1
                      IF (JG.GT.1) THEN
                          DO JJ = 2, JG
                              X2 = MLREE1.PROG(JJ)
                              IF (DABS(X1 - X2).GT.XSPETI*DABS(X2)) THEN
                                  LL = LL+1
                                  PROG(LL) = X2
                                  X1 = X2
                              ENDIF
                          ENDDO
                      ENDIF
                      JG = LL
                      SEGADJ,MLREEL
                      SEGDES,MLREEL
 20                   SEGDES,MLREE1
                  ENDIF
*
                  CALL ECROBJ('LISTREEL',MLREEL)
              ENDIF
          ENDIF
*
*     +-----------------------------------------------------+
*     |             O B J E T   L I S T E N T I             |
*     +-----------------------------------------------------+
*
      ELSEIF (NUMLIS .EQ. 2) THEN
*
*         DEUX OBJETS LISTENTI ONT ETE FOURNIS
*         *************************************************
          IF (IRET2.NE.0) THEN
C               MLENTI = IPLIST
C               MLENT1 = IPLI2
C               SEGACT MLENTI*MOD,MLENT1*MOD
              MLENT2 = IPLIST
              MLENT3 = IPLI2
              SEGACT,MLENT2,MLENT3
              SEGINI,MLENTI=MLENT2,MLENT1=MLENT3
              SEGDES,MLENT2,MLENT3
*
              IF (LECT(/1).GT.MLENT1.LECT(/1)) THEN
                  SEGDES MLENTI,MLENT1
c la seconde suite doit être au moins aussi longue
                  CALL ERREUR(3)
                  RETURN
              ENDIF
              JG = LECT(/1)
              NT1 = JG
              SEGINI MLREEL,MLREE2
              DO IV = 1,JG
                  PROG(IV) = LECT(IV)
              ENDDO
              JG = MLENT1.LECT(/1)
              SEGINI MLENT3
              IF (ABSOLU) THEN
                  DO IV = 1,JG
                      MLREEL.PROG(IV) = DABS(MLREEL.PROG(IV))
                  ENDDO
                  DO IV = 1,JG
                      MLENT1.LECT(IV) = ABS(MLENT1.LECT(IV))
                  ENDDO
              ENDIF
              CALL TRIFLO(MLREEL.PROG(1),MLREE2.PROG(1),
     &                    MLENT1.LECT(1),MLENT3.LECT(1),NT1)
              IF (.NOT.CROISS) THEN
                  DO IV = 1,JG
                      PROG(IV) = MLREE2.PROG(IV)
                      MLENT3.LECT(IV) = MLENT1.LECT(IV)
                  ENDDO
                  DO IV = 1,JG
                      PROG(IV) = MLREE2.PROG(JG + 1 - IV)
                      MLENT1.LECT(IV) = MLENT3.LECT(JG + 1 - IV)
                  ENDDO
              ENDIF
              DO IV = 1,NT1
                  MLENTI.LECT(IV) = INT(MLREEL.PROG(IV))
              ENDDO
              SEGSUP,MLREEL,MLREE2,MLENT3
              SEGDES,MLENTI, MLENT1
*
              CALL ECROBJ('LISTENTI',MLENT1)
              CALL ECROBJ('LISTENTI',MLENTI)
*
*         UN SEUL OBJET LISTENTI A ETE FOURNI
*         *************************************************
          ELSE
              MLENT1 = IPLIST
              SEGACT,MLENT1
              SEGINI,MLENTI=MLENT1
              SEGDES,MLENT1
              IPLIST = MLENTI
*
              CALL ORDON2 (IPLIST,CROISS,ABSOLU)
              IF (STRICT) THEN
                  MLENT1 = IPLIST
                  SEGACT MLENT1
                  JG = MLENT1.LECT(/1)
                  IF (JG.EQ.0) GOTO 30
                  SEGINI MLENTI
                  LECT(1) = MLENT1.LECT(1)
                  M1 = LECT(1)
                  LL = 1
                  IF (JG.GT.1) THEN
                      DO JJ = 2, JG
                          M2 = MLENT1.LECT(JJ)
                          IF (M1.NE.M2) THEN
                              LL = LL+1
                              LECT(LL) = M2
                              M1 = M2
                          ENDIF
                      ENDDO
                  ENDIF
                  JG = LL
                  SEGADJ,MLENTI
                  SEGDES,MLENTI
  30              SEGDES,MLENT1
              ENDIF
*
              CALL ECROBJ('LISTENTI',MLENTI)
          ENDIF
*
*     +-----------------------------------------------------+
*     |            O B J E T   E V O L U T I O N            |
*     +-----------------------------------------------------+
*
      ELSEIF (NUMLIS .EQ. 3) THEN
          MEVOL1 = IPLIST
          SEGACT,MEVOL1
          SEGINI,MEVOLL=MEVOL1
          SEGDES,MEVOL1
          IPLIST = MEVOLL
*
         CALL ORDON3 (IPLIST,CROISS,ABSOLU)
*
         CALL ECROBJ('EVOLUTIO',MEVOLL)
*
*     +-----------------------------------------------------+
*     |             O B J E T   M A I L L A G E             |
*     +-----------------------------------------------------+
*
      ELSEIF (NUMLIS .EQ. 4) THEN
          IPT2 = IPLIST
          SEGACT,IPT2
          SEGINI,IPT1=IPT2
          SEGDES,IPT2
          IPLIST = IPT1
*
          CALL ORDON4 (IPLIST)
*
          CALL ECROBJ('MAILLAGE',IPT1)

      ENDIF



      RETURN

      END