Sources Esope | Cast3M

elimin3
C ELIMIN3   SOURCE    SP204843  23/07/17    21:15:04     11710          
 
************************************************************************
* NOM         : ELIMIN3
* DESCRIPTION : Supprime les doublons dans un LISTREEL
************************************************************************
* HISTORIQUE : 22/05/2012 : JCARDO : Creation de la subroutine
* HISTORIQUE : 21/12/2012 : OF : Adaptation a UNIQue
************************************************************************
* Priere de PRENDRE LE TEMPS DE COMPLETER LES COMMENTAIRES
* en cas de modification de ce sous-programme afin de faciliter
* la maintenance !
************************************************************************
* SYNTAXE (GIBIANE)
*        LREELS = UNIQ LREELE (FLOT1) ;
************************************************************************
 
      SUBROUTINE ELIMIN3(IPLREE,ICRIT,RCRIT)
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
-INC SMLREEL
 
      MLREE1 = IPLREE
      SEGINI,MLREEL=MLREE1
 
      NN = PROG(/1)
 
c Recherche des doublons (a la precision pres)
      IF (NN.GT.1) THEN
        JG = 1
        IF (ICRIT.EQ.0) THEN
          DO 10 I = 2, NN
            R_ZI = PROG(I)
            R_ZA = ABS(R_ZI)
            DO J = 1, JG
              R_ZJ = PROG(J)
              XCRIT = RCRIT * MAX(R_ZA, ABS(R_ZJ))
              IF (ABS(R_ZI-R_ZJ).LT.XCRIT) GOTO 10
            ENDDO
            JG = JG + 1
            PROG(JG) = R_ZI
 10       CONTINUE
        ELSE
          DO 11 I = 2, NN
            R_ZI = PROG(I)
            DO J = 1, JG
              IF (ABS(R_ZI-PROG(J)).LT.RCRIT) GOTO 11
            ENDDO
            JG = JG + 1
            PROG(JG) = R_ZI
 11       CONTINUE
        ENDIF
        IF (JG.NE.NN) SEGADJ,MLREEL
      ENDIF
      IF (JG.EQ.NN) THEN
        SEGSUP,MLREEL
      ELSE
        SEGDES,MLREEL
        IPLREE = MLREEL
      ENDIF
 
      RETURN
      END