Sources Esope | Cast3M

fuslre
C FUSLRE    SOURCE    CHAT      05/01/13    00:12:44     5004
      SUBROUTINE FUSLRE (MLREE1,MLREE2,  MLREE3)
************************************************************************
*
*                             F U S L R E
*                             -----------
*
* FONCTION:
* ---------
*
*     FUSION DE 2 "LISTREEL" ORDONNES STRICTEMENT CROISSANT, PAR
*     INSERTION, DANS LE 1ER, DES REELS N'APPARTENANT QU'AU 2IEME.
*
* MODULES UTILISES:
* -----------------
*
      IMPLICIT INTEGER(I-N)
-INC SMLREEL
-INC SMLENTI
*
* PARAMETRES:   (E)=ENTREE   (S)=SORTIE   (+ = CONTENU DANS UN COMMUN)
* -----------
*
*     MLREE1  (E)  1ER LISTREEL ORDONNE.
*     MLREE2  (E)  2EME LISTREEL ORDONNE.
*     MLREE3  (S)  FUSION ORDONNEE STRICTEMENT CROISSANT DES 2 LISTREEL.
*
* CONSTANTES:
* -----------
*
      REAL*8 EPS,EPS9
      PARAMETER (EPS = 1.D-3)
      PARAMETER (EPS9 = 1.D0-EPS)
*
* VARIABLES:
* ----------
*
*     NEAR   = RR TRES VOISIN D'UNE VALEUR DANS LA LISTE "MLREE1".
*     RR     = VALEUR COURANTE DE LA LISTE "MLREE2".
*
      REAL*8 RR,AR
      LOGICAL NEAR
*
* AUTEUR, DATE DE CREATION:
* -------------------------
*
*     PASCAL MANIGOT     9 SEPTEMBRE 1988
*
* LANGAGE:
* --------
*
*     ESOPE + FORTRAN77
*
************************************************************************
*
      SEGACT,MLREE1,MLREE2
      LDIM1 = MLREE1.PROG(/1)
      LDIM2 = MLREE2.PROG(/1)
*
      JG = LDIM2
      SEGINI,MLENTI
*     CETTE TABLE, ASSOCIEE A "MLREE2", VA INDIQUER LA POSITION
*     D'INSERTION DE CHAQUE REEL (=0 S'IL NE FAUT PAS L'INSERER).
*
      IR = 0
      NBINSE = 0
*
      DO 100 IB=1,LDIM2
*
         RR = MLREE2.PROG(IB)
         IDEB = MAX(1,IR)
         CALL PLACE3 (MLREE1.PROG,IDEB,LDIM1,RR,  IR,AR)
*
         IF (IR .EQ. 0) THEN
            NEAR = AR .LT. EPS
         ELSE IF (IR .EQ. LDIM1) THEN
            NEAR = AR .LT. EPS
         ELSE
            NEAR = AR.LT.EPS .OR. AR.GT.EPS9
         END IF
*
         IF (NEAR) THEN
            LECT(IB) = 0
         ELSE
            LECT(IB) = IR + 1
            NBINSE = NBINSE + 1
         END IF
*
  100    CONTINUE
*     END DO
*
      JG = LDIM1 + NBINSE
      SEGINI,MLREE3
      IDEB2 = 1
      I3 = 0
*
      DO 200 IB=1,LDIM1
*
         IF (NBINSE .GT. 0) THEN
            I2 = IDEB2
            DO 210 IB2=I2,JG
               IF (LECT(IB2) .GT. IB) THEN
                  IDEB2 = IB2
                  GOTO 212
*                 EXIT
               END IF
               IF (LECT(IB2) .EQ. IB) THEN
                  I3 = I3 + 1
                  MLREE3.PROG(I3) = MLREE2.PROG(IB2)
                  NBINSE = NBINSE - 1
               END IF
  210          CONTINUE
*           END DO
  212       CONTINUE
         END IF
*
         I3 = I3 + 1
         MLREE3.PROG(I3) = MLREE1.PROG(IB)
*
  200    CONTINUE
*     END DO
*
      IF (I3.LT.JG) THEN
         I4 = I3 + 1
         DO 220 IB = I4,JG
            DO 222 IB2 = 1,LDIM2
               IF (LECT(IB2).EQ.IB) THEN
                  I3 = I3 + 1
                  MLREE3.PROG(I3) = MLREE2.PROG(IB2)
*                 EXIT
                  GOTO 220
               ENDIF
222            CONTINUE
*           END DO
220         CONTINUE
*        END DO
      END IF
*
      SEGSUP,MLENTI
      SEGDES,MLREE1,MLREE2
      SEGDES,MLREE3
*
      END