C ADCHEL    SOURCE    OF166741  25/02/21    21:15:03     12166          
      SUBROUTINE ADCHEL(IPCHE1,IPCHE2,IPCHAD,IEPS)
C_______________________________________________________________________
C
C         ADDITION / SOUSTRACTION DE 2 CHPS PAR ELEMENTS
C
C         ( ADDITION :IEPS=1 ; SOUSTRACTION IEPS=-1 )
C
C     ENTREE :
C     --------
C
C        IPCHE1  POINTEUR SUR LE PREMIER CHAMPS (TYPE MCHAML)
C        IPCHE2  POINTEUR SUR LE DEUXIEME CHAMPS (TYPE MCHALM)
C        IEPS    = 1  ADDITION
C                =-1  SOUSTRACTION
C
C     SORTIE :
C     ________
C
C        IPCHAD  POINTEUR SUR LE CHAMPS SOMME (TYPE MCHAML)
C                = 0  SI L OPERATION EST IMPOSSIBLE
C
C         MESSAGE D ERREUR DECHENCHE SI IPCHAD=0
C
C     LES 2 CHAM PAR ELEMENT PEUVENT AVOIR DES SUPPORTS GEOMETRIQUES
C     DIFFERENTS POUR PEU QUE LES OBJETS AFFECTES ELEMENTAIRES QUI LES
C     SOUS TENDENT   FORMENT UNE PARTITION DE LA GEOMETRIE
C
C     CODE EBERSOLT JUILLET 84   PASSAGE 4331 FEVRIER 85
C
C    ON PEUT ADDITIONNER A UN CHAMELEM QUELCONQUE UN CHAMELEM A UNE
C   COMPOSANTE
C
C     MODIFIE SEPTEMBRE 86
C
C     PASSAGE AUX NOUVEAU CHAMELEM PAR JM CAMPENON LE 29 10 90
C +PP     EXTENSION ADDITION P.PEGON 24/11/92
C
C     CB215821 : Gestion de la soustraction avec des SOUS-ZONES disjointes
C_______________________________________________________________________
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)

-INC PPARAM
-INC CCOPTIO

-INC SMCHAML
-INC SMLREEL
-INC SMCOORD

      CHARACTER*16 TYPCH2

      SEGMENT MZONG
        INTEGER NZONG(0)
      ENDSEGMENT

      SEGMENT MZON1
        INTEGER NZON1(0)
      ENDSEGMENT

      SEGMENT MZON2
        INTEGER NZON2(0)
      ENDSEGMENT
C
      SEGMENT ITAFF
        INTEGER JTAFF(0)
      ENDSEGMENT
C
      PARAMETER ( NINF=3 )
      INTEGER INFOS(NINF)
      CHARACTER*72 MOT
      CHARACTER*16 CONCH1,CONCH2
      LOGICAL      BOOLSO
C
      BOOLSO=.FALSE.

      IF(IEPS.EQ. 1) XX= 1.D0
      IF(IEPS.EQ.-1) XX=-1.D0
C      if (ieps.eq.-1) then
C        write (6,*) ' adchel soustraction de chamelem '
C      endif

      IF(IPCHE1.NE.IPCHE2) GOTO 1000
C
C     SI LES 2 POINTEURS SONT EGAUX TRAITEMENT SPECIAL
C
      MCHEL1=IPCHE1
      MCHEL2=IPCHE2
      SEGINI,MCHELM=MCHEL1
      IPCHAD = MCHELM
      NSOUS = IMACHE(/1)
      IF (IEPS.EQ. 1) XX=2.D0
      IF (IEPS.EQ.-1) XX=0.D0

      DO 110 IA=1,NSOUS
         MCHAM1=ICHAML(IA)
         SEGINI,MCHAML=MCHAM1
         ICHAML(IA)=MCHAML
         DO 111 ICOMP=1,IELVAL(/1)
            MELVA1 = IELVAL(ICOMP)
            SEGACT,MELVA1
            SEGINI,MELVAL=MELVA1
            N1PTEL=VELCHE(/1)
            IF (N1PTEL.EQ.0) THEN
               N2PTEL=IELCHE(/1)
               N2EL  =IELCHE(/2)
               IF (TYPCHE(ICOMP).EQ.'POINTEURLISTREEL') THEN
                  DO 122 IB=1,N2EL
                     DO 121 IGAU=1,N2PTEL
                        MLREE1=IELCHE(IGAU,IB)
                        IF(MLREE1.EQ.0)THEN
                           MLREEL=MLREE1
                        ELSE
                           SEGACT MLREE1
                           JG=MLREE1.PROG(/1)
                           SEGINI MLREEL
                           DO 123 IPROG=1,JG
                              PROG(IPROG)=XX*MLREE1.PROG(IPROG)
 123                       CONTINUE
                        ENDIF
                        IELCHE(IGAU,IB)=MLREEL
 121                 CONTINUE
 122              CONTINUE
               ELSE IF (TYPCHE(ICOMP).EQ.'POINTEUREVOLUTIO') THEN
                  DO 126 IB=1,N2EL
                     DO 125 IGAU=1,N2PTEL
                        MEVOL1=IELCHE(IGAU,IB)
                        CALL ADEVOL(MEVOL1,MEVOL1,MEVOL2,IEPS)
                        IELCHE(IGAU,IB)=MEVOL2
 125                 CONTINUE
 126              CONTINUE
               ELSE IF (TYPCHE(ICOMP).EQ.'POINTEURPOINT   ') THEN
                  SEGACT,MCOORD*mod
                  NBNO=NBPTS
                  NBNOI=NBNO
                  NBPTS=NBNO+(N2PTEL*N2EL)
                  SEGADJ,MCOORD
                  DO 132 IB=1,N2EL
                     DO 131 IGAU=1,N2PTEL
                        IP=IELCHE(IGAU,IB)
                        IF(IP.EQ.0)THEN
                           NBPTS=IP
                        ELSE
                           IREF=(IP-1)*(IDIM+1)
                           DO 133 IC=1,IDIM
                           XCOOR(NBNOI*(IDIM+1)+IC)=XCOOR(IREF+IC)*XX
 133                       CONTINUE
                     XCOOR(NBNOI*(IDIM+1)+(IDIM+1))=XCOOR(IREF+(IDIM+1))
                        ENDIF
                        IELCHE(IGAU,IB)=NBNOI+1
                        NBNOI=NBNOI+1
 131                 CONTINUE
 132              CONTINUE
               ELSE
C
C                 NOM DE COMPOSANTE NON RECONNU
C
                  MOTERR(1:4)=NOMCHE(ICOMP)
                  CALL ERREUR(197)
                  IPCHAD=0
                  SEGSUP MELVAL,MCHAML,MCHELM
                  RETURN
               ENDIF
            ELSE
               N1EL=VELCHE(/2)
               DO IB=1,N1EL
                  DO IGAU=1,N1PTEL
                     VELCHE(IGAU,IB)=XX*VELCHE(IGAU,IB)
                  ENDDO
               ENDDO
            ENDIF
            IELVAL(ICOMP) = MELVAL
  111    CONTINUE
  110 CONTINUE
      GOTO 777

C_______________________________________________________________________
C
C      CAS GENERAL
C_______________________________________________________________________
C
 1000 CONTINUE
      MCHEL1=IPCHE1
      MCHEL2=IPCHE2
      SEGACT,MCHEL1,MCHEL2
C
C     ERREUR IMPOSSIBLE D ADDITIONNER DES CHPS/ELMTS
C     DE SS TYPE DIFFERENTS
C
      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
C
      MOT=MCHEL1.TITCHE
      L1=MCHEL1.TITCHE(/1)
      IF (MOT.EQ.'NOEUD'.OR.MOT.EQ.'GRAVITE' .OR.MOT.EQ.'RIGIDITE'.OR.
     &    MOT.EQ.'MASSE'.OR.MOT.EQ.'STRESSES'.OR.MOT.EQ.'SCALAIRE') THEN
         MOT= MCHEL2.TITCHE
         L1 = MCHEL2.TITCHE(/1)
      ENDIF
      N3    =MCHEL1.INFCHE(/2)
C* On doit avoir N3=6
      NSOUS1=MCHEL1.ICHAML(/1)
      NSOUS2=MCHEL2.ICHAML(/1)
C
C QUELLE BIJECTION ENTRE LES SOUS PAQUETS  SI OUI TRAITEMENT AMELIORE
C
      IF (NSOUS1.NE.NSOUS2) GOTO 4000
C
      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
C
C              VERIFICATION POUR LES INFCHE
C
               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)
c*               IF (IMINT1.EQ.0) IMINT1 = 1
               IMINT2 = MCHEL2.INFCHE(ISOUS2,6)
c*               IF (IMINT2.EQ.0) IMINT2 = 1
               IF (IMINT1.EQ.IMINT2) GOTO 171
C
C              ERREUR IMPOSSIBLE D ADDITIONNER DES CHPS/ELMTS
C              DE SS TYPE DIFFERENTS
C
               MOTERR(1:8)=MCHEL1.TITCHE
               MOTERR(9:16)=MCHEL2.TITCHE
               CALL ERREUR(329)
               SEGSUP ITAFF
               IPCHAD=0
               RETURN
            ENDIF
  18     CONTINUE
         SEGSUP ITAFF
         GOTO 4000

  171    CONTINUE
C        Ici, les zones ISOUS1 et ISOUS2 ont meme maillage,
c        meme constituant, meme segment d'integration
         JTAFF(**)=MCHEL2.ICHAML(ISOUS)

  17  CONTINUE
C
C     ON A TROUVE UNE BIJECTION ET ON VECTORISE
C
      N1=NSOUS1
C*      N3 = 6
      SEGINI MCHELM
      TITCHE=MOT
      IFOCHE=IFOUR
      IPCHAD=MCHELM
      DO 400 ISOUS=1,NSOUS1
         IMACHE(ISOUS)=MCHEL1.IMACHE(ISOUS)
         CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS)
         DO 401 N33=1,N3
            INFCHE(ISOUS,N33)=MCHEL1.INFCHE(ISOUS,N33)
 401     CONTINUE
C
         MCHAM1=MCHEL1.ICHAML(ISOUS)
C
         SEGINI,MCHAML=MCHAM1
         ICHAML(ISOUS)=MCHAML
         IPCHA=MCHAML
C
         MCHAM2=JTAFF(ISOUS)
         SEGACT MCHAM2
         IPCHA2=MCHAM2
C
         CALL ADCHAM (IPCHA2,IPCHA,XX)
         IF (IPCHA.EQ.0) THEN
            SEGSUP ITAFF
            GOTO 9990
         ENDIF
C
  400 CONTINUE
      SEGSUP ITAFF
      GOTO 666
C_______________________________________________________________________
C
C     ON A PAS TROUVE DE BIJECTION
C_______________________________________________________________________
C
 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
C
C              VERIFICATION POUR LES MINTES
C
               IF ( MCHEL1.INFCHE(ISOUS1,6).EQ.
     &              MCHEL2.INFCHE(ISOUS2,6) ) GOTO 530
C
C              ERREUR SUR LES SUPPORTS DES MCHAML
C
               MOTERR(1:8) =MCHEL1.TITCHE
               MOTERR(9:16)=MCHEL2.TITCHE
               CALL ERREUR(329)
               IPCHAD=0
               SEGSUP MZONG,MZON1,MZON2
               RETURN
            ENDIF
  520    CONTINUE
         IWRN=1
         NZONG(**)=IPMAI2
         NZON1(**)=0
         NZON2(**)=ISOUS2
         GOTO 510
C
  530    CONTINUE
         if (nzon2(isous1).ne.0) call erreur(329)
         NZON2(ISOUS1)=ISOUS2
  510 CONTINUE
C
C   WARNING  LES SOUS ZONES GEOMETRIQUES NE SE CORRESPONDENT PAS 2 A 2
C
      NSOUS=NZONG(/1)
      N1=NSOUS
C*      N3=6
      SEGINI MCHELM
      TITCHE=MOT
      IFOCHE=IFOUR
      IPCHAD=MCHELM
C
      DO 540 ISOUS=1,NSOUS
         BOOLSO=.FALSE.
         IF(NZON1(ISOUS).NE.0.AND.NZON2(ISOUS).NE.0) GOTO 550
C
         IF(NZON1(ISOUS).NE.0) THEN
            MCHAM1=MCHEL1.ICHAML( NZON1(ISOUS) )
            SEGINI,MCHAML=MCHAM1
            IMACHE(ISOUS)=NZONG(ISOUS)
            CONCHE(ISOUS)=MCHEL1.CONCHE( NZON1(ISOUS) )
            DO 402 N33=1,N3
               INFCHE(ISOUS,N33)=MCHEL1.INFCHE(NZON1(ISOUS),N33)
 402        CONTINUE
         ENDIF
         IF(NZON2(ISOUS).NE.0) THEN
            IF(IEPS .EQ. -1) BOOLSO=.TRUE.
            MCHAM2=MCHEL2.ICHAML( NZON2(ISOUS) )
            SEGINI,MCHAML=MCHAM2
            IMACHE(ISOUS)=NZONG(ISOUS)
            CONCHE(ISOUS)=MCHEL2.CONCHE( NZON2(ISOUS) )
            DO 403 N33=1,N3
               INFCHE(ISOUS,N33)=MCHEL2.INFCHE(NZON2(ISOUS),N33)
 403        CONTINUE
         ENDIF
         ICHAML(ISOUS)=MCHAML
C
         DO 175 ICOMP=1,IELVAL(/1)
            MELVA1=IELVAL(ICOMP)
            SEGACT,MELVA1
            SEGINI,MELVAL=MELVA1
            IELVAL(ICOMP)=MELVAL
C CB215821  Si c'est la soustraction qu'on demande il faut faire * XX...
C           sur les SOUS-ZONES issues du 2ème MCHAML (BOOLSO = .TRUE.)
            IF (BOOLSO) THEN
                TYPCH2=TYPCHE(ICOMP)
                CALL MULMEL(MELVAL,XX,TYPCH2)
            ENDIF
 175     CONTINUE
C
         GOTO 540
C
  550    CONTINUE
         MCHAM1=MCHEL1.ICHAML( NZON1(ISOUS) )
         SEGINI,MCHAML=MCHAM1
         IMACHE(ISOUS)=NZONG(ISOUS)
         CONCHE(ISOUS)=MCHEL1.CONCHE( NZON1(ISOUS) )
         DO 404 N33=1,N3
            INFCHE(ISOUS,N33)=MCHEL1.INFCHE(NZON1(ISOUS),N33)
 404     CONTINUE
         ICHAML(ISOUS)=MCHAML
         IPCHA=MCHAML
         MCHAM2=MCHEL2.ICHAML( NZON2(ISOUS) )
         SEGACT MCHAM2
         IPCHA2=MCHAM2
C
         CALL ADCHAM (IPCHA2,IPCHA,XX)
         IF (IPCHA.EQ.0) THEN
            SEGSUP MZONG,MZON1,MZON2
            GOTO 9990
         ENDIF
C
  540 CONTINUE
C
      SEGSUP MZONG,MZON1,MZON2
      GOTO 666
C
 9990 CONTINUE
C
C     ERREUR DANS UNE SOUS ZONE : DESACTIVATION ET RETOUR
C
      SEGSUP MCHAML,MCHELM,ITAFF
      IPCHAD=0
C
  666 CONTINUE
  777 CONTINUE

      RETURN
      END