Sources Esope | Cast3M

interc
C INTERC    SOURCE    PV        20/03/30    21:20:02     10567          
C
C    CE SOUS PROGRAMME REALISE l'intersection ensembliste de deux maillages
C    simples (1 seul type d'element)
C    Les maillages IPT1 et IPT2 sont supposes ACTIF en E/S (non modifies)
C    Si pas d'intersection, IPT3 = 0 sinon pointeur MELEME (ACTIF en S)
C
      SUBROUTINE INTERC(IPT1,IPT2, IPT3)
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
 
-INC PPARAM
-INC CCOPTIO
-INC SMELEME
-INC SMCOORD
      segment ipos(nbpt)
      segment ind(mm)
 
      IPT3 = 0
 
C*      SEGACT IPT1,IPT2  &lt;- Segments actifs en Entree
      NBNN1=IPT1.NUM(/1)
      NBNN2=IPT2.NUM(/1)
C Un des maillages n'est pas simple :
      IF (NBNN1.EQ.0 .OR. NBNN2.EQ.0) GOTO 900
 
      NBELE1=IPT1.NUM(/2)
      NBELE2=IPT2.NUM(/2)
      ITYP1 =IPT1.ITYPEL
      ITYP2 =IPT2.ITYPEL
 
C Les maillages ne sont pas du meme type :
      IF ((ITYP1.NE.ITYP2) .OR. (NBNN1.NE.NBNN2)) GOTO 900
 
      NBNN   = NBNN1
      NBELEM = MAX(NBELE1,NBELE2)
      NBREF  = 0
      NBSOUS = 0
      SEGINI,MELEME
      ITYPEL = ITYP1
 
C Creation de ipos
      SEGACT,mcoord
      np    = nbpts   
      nbpt = np + 1
      SEGINI,ipos
C Remplissage de ipos
      DO 10 i = 1, NBELE1
        DO 11 j = 1, NBNN1
          ia=ipt1.num(j,i)
          ipos(ia)=ipos(ia)+1
 11     CONTINUE
 10   CONTINUE
      i_z = ipos(1)
      DO 13 i = 2, np
        i_z = i_z + ipos(i)
        ipos(i) = i_z
 13   CONTINUE
      mm = ipos(np)
      ipos(nbpt) = mm
C Creation de ind
      SEGINI,ind
C Remplissage de ind
      DO 20 i = 1, NBELE1
        DO 21 j = 1, NBNN1
          ia = ipt1.num(j,i)
          ide=ipos(ia)
          ind(ide)=i
          ipos(ia)=ide-1
 21     CONTINUE
 20   CONTINUE
 
* Remplissage de l'intersection
      I=0
      DO 1 i1 = 1, NBELE2
        ia=ipt2.num(1,i1)
        ideb=ipos(ia)+1
        ifin=ipos(ia+1)
        IF (ifin.lt.ideb) go to 1
        DO 2 ie=ideb,ifin
          iel=ind(ie)
          DO 134 in1=1,NBNN1
            DO 136 in2=1,NBNN2
              IF(ipt1.num(in1,iel).EQ.ipt2.num(in2,i1)) GOTO 134
  136       CONTINUE
            GOTO 2
  134     CONTINUE
C       OK pour cet element
          I=I+1
          ICOLOR(I)=IPT1.ICOLOR(Iel)
          DO 135 J=1,NBNN
            NUM(J,I)=IPT1.NUM(J,iel)
 135      CONTINUE
          GOTO 1
 2      CONTINUE
 1    CONTINUE
 
      SEGSUP,ipos,ind
 
      NBELEM = I
      IF (NBELEM.EQ.0) THEN
        SEGSUP,MELEME
        IPT3 = 0
      ELSE
        SEGADJ,MELEME
C*        SEGDES,MELEME     &lt;- Segment cree actif en sortie
        IPT3 = MELEME
      ENDIF
 
 900  CONTINUE
C*      SEGDES,IPT1,IPT2  &lt;- Segments actifs en Sortie (non modifies)
 
      RETURN
      END