C PILEPS    SOURCE    OF166741  25/02/21    21:18:08     12166          
*
* but : soit deux champs de epsilon il faut trouver le lambda max
*     tel que:   eps1 + lambda*eps2  = signe(eps2) * crit
*
      SUBROUTINE PILEPS

      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)

-INC PPARAM
-INC CCOPTIO

-INC SMCHAML
-INC SMLREEL

      SEGMENT MZONG
         INTEGER NZONG(0)
      ENDSEGMENT
      SEGMENT MZON1
         INTEGER NZON1(0)
      ENDSEGMENT
      SEGMENT MZON2
         INTEGER NZON2(0)
      ENDSEGMENT
      SEGMENT ITAFF
         INTEGER JTAFF(0)
      ENDSEGMENT
      SEGMENT NOMID
        CHARACTER*8 LESOBL(NBROBL),LESFAC(NBRFAC)
      ENDSEGMENT

      PARAMETER ( NINF=3 )
      INTEGER INFOS(NINF)
      CHARACTER*72 MOT
      CHARACTER*16 CONCH1,CONCH2

*  lecture des champs et du flottant
       CALL LIROBJ('MCHAML  ',IPCHE1,1,IRETOU)
       CALL ACTOBJ('MCHAML  ',IPCHE1,1)
       IF(IERR.NE.0) RETURN
       CALL LIROBJ('MCHAML  ',IPCHE2,1,IRETOU)
       CALL ACTOBJ('MCHAML  ',IPCHE2,1)
       IF(IERR.NE.0) RETURN
       CALL LIRREE(XCRIT,1,IRETOU)
       IF(IERR.NE.0) RETURN
*  fin de lecture

      XLAMB = 1.D+50

      IF(IPCHE1.NE.IPCHE2) GOTO 1000
*
*     SI LES 2 POINTEURS SONT EGAUX TRAITEMENT SPECIAL
*
      MCHELM=IPCHE1
      NSOUS = IMACHE(/1)
*
      DO 110 IA=1,NSOUS
         MCHAML=ICHAML(IA)
         ICHAML(IA)=MCHAML
         DO 111 ICOMP=1,IELVAL(/1)
            MELVAL = IELVAL(ICOMP)
            N1PTEL = VELCHE(/1)
            N1EL   = VELCHE(/2)
            IF (N1PTEL.EQ.0) THEN
               CALL ERREUR(19)
               RETURN
            ENDIF
            DO IB = 1, N1EL
              DO IGAU=1,N1PTEL
                r_z = VELCHE(IGAU,IB)
                IF ( r_z .NE. 0.D0 ) THEN
                  XLA = (SIGN( XCRIT,r_z ) - r_z) / r_z
                  XLAMB = MIN ( XLAMB , XLA )
                ENDIF
              ENDDO
            ENDDO
  111    CONTINUE
  110 CONTINUE
      GOTO 777

*_______________________________________________________________________
*
*      CAS GENERAL
*_______________________________________________________________________
 1000 CONTINUE
      MCHEL1=IPCHE1
      MCHEL2=IPCHE2
*
*     ERREUR IMPOSSIBLE D ADDITIONNER DES CHPS/ELMTS
*     DE SS TYPE DIFFERENTS
*
      IF (MCHEL1.IFOCHE.NE.MCHEL2.IFOCHE) THEN
        MOTERR(1:16)=MCHEL1.TITCHE(1:8)//MCHEL2.TITCHE(1:8)
        CALL ERREUR(99)
        IPCHAD=0
        GOTO 666
      ENDIF

      NSOUS1=MCHEL1.ICHAML(/1)
      NSOUS2=MCHEL2.ICHAML(/1)
*
* QUELLE BIJECTION ENTRE LES SOUS PAQUETS  SI OUI TRAITEMENT AMELIORE
*
      IF (NSOUS1.NE.NSOUS2) GOTO 4000
*
      SEGINI ITAFF
      DO 17 ISOUS1=1,NSOUS1
         IPMAI1 = MCHEL1.IMACHE(ISOUS1)
         CONCH1  = MCHEL1.CONCHE(ISOUS1)
         DO 18 ISOUS2=1,NSOUS2
            ISOUS=ISOUS2
            IPMAI2= MCHEL2.IMACHE(ISOUS)
            CONCH2= MCHEL2.CONCHE(ISOUS)
            IF(IPMAI1.EQ.IPMAI2.AND.CONCH1.EQ.CONCH2) THEN
*
*              VERIFICATION POUR LES INFCHE
*
               CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD)
               IF (IRTD.EQ.0) GOTO 18
               IMINT1=MCHEL1.INFCHE(ISOUS1,4)
               IMINT2=MCHEL2.INFCHE(ISOUS2,4)
               IF (IMINT1.EQ.IMINT2) GOTO 171
               IMINT1 = MCHEL1.INFCHE(ISOUS1,6)
               IMINT2 = MCHEL2.INFCHE(ISOUS2,6)
               IF (IMINT1.EQ.IMINT2) GOTO 171
*
*              ERREUR IMPOSSIBLE D ADDITIONNER DES CHPS/ELMTS
*              DE SS TYPE DIFFERENTS
               CALL ERREUR(19)
               SEGSUP ITAFF
               RETURN
            ENDIF
  18     CONTINUE
         SEGSUP ITAFF
         GOTO 4000
*
  171    CONTINUE
         JTAFF(**)=MCHEL2.ICHAML(ISOUS)
  17  CONTINUE
*
*     ON A TROUVE UNE BIJECTION   ET ON VECTORISE
*
      N1=NSOUS1
      DO 400 ISOUS=1,NSOUS1

         MCHAML=MCHEL1.ICHAML(ISOUS)
*
         IPCHA=MCHAML
*
         MCHAM2=JTAFF(ISOUS)
         IPCHA2=MCHAM2
*
         CALL PILEP1 (IPCHA2,IPCHA,XLAMB,XCRIT)
         IF (IPCHA.EQ.0) THEN
            SEGSUP ITAFF
            GOTO 9990
         ENDIF
*
  400 CONTINUE
      SEGSUP ITAFF
      GOTO 777
*_______________________________________________________________________
*
*     ON A PAS TROUVE DE BIJECTION
*_______________________________________________________________________
*
 4000 CONTINUE
      SEGINI MZONG,MZON1,MZON2
      DO 500 ISOUS1=1,NSOUS1
         NZONG(**)=MCHEL1.IMACHE(ISOUS1)
         NZON1(**)=ISOUS1
         NZON2(**)=0
  500 CONTINUE
      IWRN=0
      DO 510 ISOUS2=1,NSOUS2
         IPMAI2 = MCHEL2.IMACHE(ISOUS2)
         CONCH2 = MCHEL2.CONCHE(ISOUS2)
         DO 520 ISOUS1=1,NSOUS1
            IPMAI1= MCHEL1.IMACHE(ISOUS1)
            CONCH1= MCHEL1.CONCHE(ISOUS1)
            IF(IPMAI1.EQ.IPMAI2 .AND.CONCH1.EQ.CONCH2) THEN
               CALL IDENT (IPMAI1,CONCH1,IPCHE1,IPCHE2,INFOS,IRTD)
               IF (IRTD.EQ.0) GOTO 520
*
*              VERIFICATION POUR LES MINTES
*
               IF ( MCHEL1.INFCHE(ISOUS1,4).EQ.
     &              MCHEL2.INFCHE(ISOUS2,4) ) GOTO 530
*
*              ERREUR SUR LES SUPPORTS DES MCHAML
*
               CALL ERREUR(19)
               SEGSUP MZONG,MZON1,MZON2
               RETURN
*
            ENDIF
  520    CONTINUE
         IWRN=1
         NZONG(**)=IPMAI2
         NZON1(**)=0
         NZON2(**)=ISOUS2
         GOTO 510
*
  530    CONTINUE
         NZON2(ISOUS1)=ISOUS2
  510 CONTINUE
*
*   WARNING  LES SOUS ZONES GEOMETRIQUES NE SE CORRESPONDENT PAS 2 A 2
*
      IF(IWRN.EQ.1)  CALL ERREUR(103)
      NSOUS=NZONG(/1)
      N1=NSOUS
*
      DO 540 ISOUS=1,NSOUS
         IF(NZON1(ISOUS).NE.0.AND.NZON2(ISOUS).NE.0) GOTO 550
*
         IF(NZON1(ISOUS).NE.0) THEN
            MCHAML=MCHEL1.ICHAML( NZON1(ISOUS) )
         ENDIF
         IF(NZON2(ISOUS).NE.0) THEN
            MCHAML=MCHEL2.ICHAML( NZON2(ISOUS) )
         ENDIF
*
         GOTO 540
*
  550    CONTINUE
         MCHAML=MCHEL1.ICHAML( NZON1(ISOUS) )
         IPCHAD=MCHAML
         MCHAM2=MCHEL2.ICHAML( NZON2(ISOUS) )
         IPCHA2=MCHAM2
*
         CALL PILEP1 (IPCHA2,IPCHA,XLAMB,XCRIT)
         IF (IPCHA.EQ.0) THEN
            SEGSUP MZONG,MZON1,MZON2
            GOTO 9990
         ENDIF
*
  540 CONTINUE
*
      SEGSUP MZONG,MZON1,MZON2
      GOTO 666
*
 9990 CONTINUE
*
*     ERREUR DANS UNE SOUS ZONE : DESACTIVATION ET RETOUR
*
      SEGSUP ITAFF

      RETURN
*
  666 CONTINUE
  777 CONTINUE
      CALL ECRREE (XLAMB)

c      RETURN
      END