C INCLU3    SOURCE    PV        20/03/24    21:18:09     10554          

      SUBROUTINE INCLU3(IPT1,IPT2)

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

-INC PPARAM
-INC CCOPTIO
-INC SMELEME
-INC SMCOORD

      SEGMENT ICPR(NNNOE)
      SEGMENT IELOP(IN)

      CHARACTER*4 LEMOT(3),LEMO2(1)
      DATA LEMOT / 'STRI','LARG','BARY' /
      DATA LEMO2 / 'NOID' /

C*    IF (IDIM.NE.3) THEN
C*      INTERR(1)=IDIM
C*      CALL ERREUR(709)
C*      RETURN
C*    ENDIF
      IDIMP1=IDIM+1

      CALL LIRMOT(LEMOT,3,IMSLU,0)
      IF (IMSLU.EQ.0) IMSLU=1

      IVERI=0
      CALL LIRMOT(LEMO2,1,IRE2,0)
      IF (IRE2.EQ.1) IVERI=1

C CRITERE D'INCLUSION :
      CALL LIRREE(XCRITT,0,IRET)
      IF (IRET.EQ.0) XCRITT=1.E-2

      SEGACT,IPT1,IPT2
      IPT1IN=IPT1
      IPT2IN=IPT2

*  Conversion de IPT1 en maillage de type POI1
* ---------------------------------------------
      segact mcoord*mod
      NBPTSI=nbpts
      IF (IPT1.ITYPEL .EQ. 1) THEN
        IF (IMSLU.EQ.3) IPT5=IPT1
      ELSE
C* Traitement de l'option 'BARY' :
C* IPT1 contiendra les centres de gravite de IPT1 (dans le meme ordre)
        IF (IMSLU.EQ.3) THEN
          NBPTS=NBPTSI
          NBNN=1
          NBELEM=0
          NBREF=0
          NBSOUS=0
          SEGINI,IPT5
          IPT5.ITYPEL=1
          IGRAV=NBPTSI
          IPT6=IPT1
          NSOU1=IPT6.LISOUS(/1)
          DO i=1,MAX(1,NSOU1)
            IF (NSOU1.NE.0) THEN
              IPT6=IPT1.LISOUS(i)
              SEGACT,IPT6
            ENDIF
            NBELE5=NBELEM
            NBELE1=IPT6.NUM(/2)
            NBELEM=NBELEM+NBELE1
            SEGADJ,IPT5
            NBPTS=NBPTS+NBELE1
            SEGADJ,MCOORD
            NBN1=IPT6.NUM(/1)
            DO j=1,NBELE1
              IGRAV=IGRAV+1
              IPT5.NUM(1,NBELE5+j)=IGRAV
              XP=0.D0
              YP=0.D0
              ZP=0.D0
              DO k=1,NBN1
                IREF=IPT6.NUM(k,j)*IDIMP1-IDIM
                XP=XCOOR(IREF)  +XP
                YP=XCOOR(IREF+1)+YP
                ZP=XCOOR(IREF+2)+ZP
              ENDDO
              IREF=IGRAV*IDIMP1-IDIM
              XCOOR(IREF  )=XP/FLOAT(NBN1)
              XCOOR(IREF+1)=YP/FLOAT(NBN1)
              XCOOR(IREF+2)=ZP/FLOAT(NBN1)
            ENDDO
            IF (NSOU1.NE.0) SEGDES,IPT6
          ENDDO
          SEGDES,IPT1
          IPT1=IPT5
C* Traitement des options 'STRI' et 'LARG'
        ELSE
          CALL CHANGE(IPT1,1)
        ENDIF
      ENDIF
      NNNOE=IPT1.NUM(/2)
*
*     Conversion de ipt2 en elements de type TET4
*
      IF (IPT2.LISOUS(/1).NE.0) THEN
        IN=IPT2.LISOUS(/1)
        SEGINI IELOP
        NBELEM=0
        DO 36 I=1,IPT2.LISOUS(/1)
          MELEME=IPT2.LISOUS(I)
          SEGACT MELEME
          IF (MELEME.ITYPEL.NE.23) THEN
            CALL CHANGE(MELEME,23)
*      write(6,*) ' inclu3 conv faite'
          ENDIF
          NBELEM=NBELEM+NUM(/2)
          IELOP(I)=MELEME
   36   CONTINUE
        NBNN=4
        NBREF=0
        NBSOUS=0
        SEGINI IPT3
        IA=0
        DO 37 I=1,IPT2.LISOUS(/1)
          MELEME=IELOP(I)
          DO 38 J=1,NUM(/2)
            DO 38 K=1,NUM(/1)
              IPT3.NUM(K,J+IA) = NUM(K,J)
  38      CONTINUE
          IA=IA+NUM(/2)
          SEGDES MELEME
   37   CONTINUE
        IPT3.ITYPEL=23
        IPT2=IPT3
      ELSE
        IF (IPT2.ITYPEL.NE.23) THEN
          CALL CHANGE (IPT2,23)
*      write(6,*) ' inclu3 conv faite'
        ENDIF
      ENDIF

      CALL INCLU4(IPT1,IPT2,ICPR,XCRITT)
*     write(6,FMT='(10i6)') (ICPR(IU),IU=1,ICPR(/1))
      IF (IERR.NE.0) GOTO 999

C     TEST ET CREATION DU SEGMENT RESULTAT
      NBREF=0
      MELEME=IPT1IN
      SEGACT MELEME
      IPT2=MELEME
      NBSOU=LISOUS(/1)
      IF (NBSOU.NE.0) THEN
        NBNN=0
        NBELEM=0
        NBSOUS=NBSOU
        SEGINI IPT8
        ISO=0
      ENDIF
      IF (IMSLU.EQ.3) THEN
        NBELE5=0
        SEGACT,IPT5
      ENDIF
      DO 270 ISOUS=1,MAX(1,NBSOU)
        IF (NBSOU.NE.0) THEN
          IPT2=LISOUS(ISOUS)
          SEGACT IPT2
        ENDIF
        NBNN=IPT2.NUM(/1)
        NBELEM=IPT2.NUM(/2)
        ICOUNT=0
        DO 250 IEL=1,NBELEM
          IF (IMSLU.EQ.1) THEN
            DO 251 INOEU=1,NBNN
              IF (ICPR(IPT2.NUM(INOEU,IEL)).EQ.0) GOTO 250
 251        CONTINUE
            ICOUNT=ICOUNT+1
          ELSE IF (IMSLU.EQ.2) THEN
            DO 252 INOEU=1,NBNN
              IF (ICPR(IPT2.NUM(INOEU,IEL)).NE.0) GOTO 253
 252        CONTINUE
            GOTO 250
 253        CONTINUE
            ICOUNT=ICOUNT+1
C*        ELSE IF (IMSLU.EQ.3) THEN
          ELSE
            IF (ICPR(IPT5.NUM(1,NBELE5+IEL)).NE.0) ICOUNT=ICOUNT+1
          ENDIF
 250    CONTINUE
        NBSOUS=0
        NBREF=0
        NBEL=NBELEM
        NBELEM=ICOUNT
        ICOUNT=1
        IF (NBELEM.EQ.0) GOTO 260
        SEGINI IPT3
        IPT3.ITYPEL=IPT2.ITYPEL
        DO 255 IEL=1,NBEL
          IF (IMSLU.EQ.1) THEN
            DO 256 INOEU=1,NBNN
              IF (ICPR(IPT2.NUM(INOEU,IEL)).EQ.0) GOTO 255
              IPT3.NUM(INOEU,ICOUNT)=IPT2.NUM(INOEU,IEL)
 256        CONTINUE
            IPT3.ICOLOR(ICOUNT)=IPT2.ICOLOR(IEL)
            ICOUNT=ICOUNT+1
            IF (ICOUNT.GT.NBELEM) GOTO 260
          ELSE IF (IMSLU.EQ.2) THEN
            IOOK=0
            DO 257 INOEU=1,NBNN
              IF (ICPR(IPT2.NUM(INOEU,IEL)).NE.0) IOOK=1
              IPT3.NUM(INOEU,ICOUNT)=IPT2.NUM(INOEU,IEL)
 257        CONTINUE
            IF (IOOK.EQ.0) GOTO 255
            IPT3.ICOLOR(ICOUNT)=IPT2.ICOLOR(IEL)
            ICOUNT=ICOUNT+1
            IF (ICOUNT.GT.NBELEM) GOTO 260
C*        ELSE IF (IMSLU.EQ.3) THEN
          ELSE
            IF (ICPR(IPT5.NUM(1,NBELE5+IEL)).NE.0) THEN
              DO INOEU=1,NBNN
                IPT3.NUM(INOEU,ICOUNT)=IPT2.NUM(INOEU,IEL)
              ENDDO
              IPT3.ICOLOR(ICOUNT)=IPT2.ICOLOR(IEL)
              ICOUNT=ICOUNT+1
              IF (ICOUNT.GT.NBELEM) GOTO 260
            ENDIF
          ENDIF
 255    CONTINUE

*       Bilan et sauvegarde

 260    CONTINUE
        IF (NBSOU.EQ.0) THEN
          IF (NBELEM.EQ.0) THEN
             IF (IVERI.EQ.1) THEN
*               Ecriture d'un maillage vide
                NBSOUS=0
                NBREF=0
                NBNN=0
                NBELEM=0
                SEGINI IPT4
                CALL ECROBJ('MAILLAGE',IPT4)
                GOTO 999
             ELSE
*              Tache impossible. Probablement données erronées
               CALL ERREUR(26)
               RETURN
             ENDIF
          ENDIF
          GOTO 280
        ENDIF
        IF (IMSLU.EQ.3) NBELE5=NBELE5+NBEL
        IF (NBELEM.NE.0) THEN
          IPT8.LISOUS(ISOUS)=IPT3
          ISO=ISO+1
          SEGDES IPT3
        ENDIF
 270  CONTINUE

      IF (ISO.EQ.1) THEN
         SEGSUP IPT8
         GOTO 280
      ENDIF
      IF (ISO.EQ.0) THEN
         SEGSUP IPT8
         IF (IVERI.EQ.1) THEN
*           Ecriture d'un maillage vide
            NBSOUS=0
            NBREF=0
            NBNN=0
            NBELEM=0
            SEGINI IPT4
            CALL ECROBJ('MAILLAGE',IPT4)
            GOTO 999
         ELSE
*          Tache impossible. Probablement données erronées
           CALL ERREUR(26)
           RETURN
         ENDIF
      ENDIF
      IPT3=IPT8
      IF (ISO.EQ.NBSOU) GOTO 280
      NBSOUS=ISO
      NBREF=0
      NBNN=0
      NBELEM=0
      SEGINI IPT4
      ISO=0
      DO 275 IS=1,NBSOU
        IF (IPT3.LISOUS(IS).EQ.0) GOTO 275
        ISO=ISO+1
        IPT4.LISOUS(ISO)=IPT3.LISOUS(IS)
 275  CONTINUE
      IF (ISO.EQ.0) THEN
        NBSOUS=0
        NBREF=0
        NBNN=0
        NBELEM=0
        SEGINI IPT4
        CALL ECROBJ('MAILLAGE',IPT4)
        GOTO 999
      ENDIF
      SEGSUP IPT3
      IPT3=IPT4
 280  CONTINUE
      SEGDES IPT3
      CALL ECROBJ('MAILLAGE',IPT3)

 999  CONTINUE
***   IF (IPT1IN.NE.IPT1) SEGSUP,IPT1
      SEGSUP,ICPR
      IPT1=IPT1IN
      IPT2=IPT2IN
      SEGDES,IPT1,IPT2
      IF (IMSLU.EQ.3) THEN
        NBPTS=NBPTSI
        SEGADJ,MCOORD
      ENDIF

      RETURN
      END