Esope source files

   1 : C INTERC    SOURCE    FANDEUR   13/01/16    21:15:22     7665           
   2 : C
   3 : C    CE SOUS PROGRAMME REALISE l'intersection ensembliste de deux maillages
   4 : C    simples (1 seul type d'element)
   5 : C    Les maillages IPT1 et IPT2 sont supposes ACTIF en E/S (non modifies)
   6 : C    Si pas d'intersection, IPT3 = 0 sinon pointeur MELEME (ACTIF en S)
   7 : C
   8 :       SUBROUTINE INTERC(IPT1,IPT2, IPT3)
   9 : 
  10 :       IMPLICIT INTEGER(I-N)
  11 :       IMPLICIT REAL*8(A-H,O-Z)
  12 : 
  13 : -INC CCOPTIO
  14 : -INC SMELEME
  15 : -INC SMCOORD
  16 :       segment ipos(nbpts)
  17 :       segment ind(mm)
  18 : 
  19 :       IPT3 = 0
  20 : 
  21 : C*      SEGACT IPT1,IPT2  <- Segments actifs en Entree
  22 :       NBNN1=IPT1.NUM(/1)
  23 :       NBNN2=IPT2.NUM(/1)
  24 : C Un des maillages n'est pas simple :
  25 :       IF (NBNN1.EQ.0 .OR. NBNN2.EQ.0) GOTO 900
  26 : 
  27 :       NBELE1=IPT1.NUM(/2)
  28 :       NBELE2=IPT2.NUM(/2)
  29 :       ITYP1 =IPT1.ITYPEL
  30 :       ITYP2 =IPT2.ITYPEL
  31 : 
  32 : C Les maillages ne sont pas du meme type :
  33 :       IF ((ITYP1.NE.ITYP2) .OR. (NBNN1.NE.NBNN2)) GOTO 900
  34 : 
  35 :       NBNN   = NBNN1
  36 :       NBELEM = MIN(NBELE1,NBELE2)
  37 :       NBREF  = 0
  38 :       NBSOUS = 0
  39 :       SEGINI,MELEME
  40 :       ITYPEL = ITYP1
  41 : 
  42 : C Creation de ipos
  43 : C*      SEGACT,mcoord  <- Segment toujours actif
  44 :       np    = xcoor(/1) / (idim+1)
  45 :       nbpts = np + 1
  46 :       SEGINI,ipos
  47 : C Remplissage de ipos
  48 :       DO 10 i = 1, NBELE1
  49 :         DO 11 j = 1, NBNN1
  50 :           ia=ipt1.num(j,i)
  51 :           ipos(ia)=ipos(ia)+1
  52 :  11     CONTINUE
  53 :  10   CONTINUE
  54 :       i_z = ipos(1)
  55 :       DO 13 i = 2, np
  56 :         i_z = i_z + ipos(i)
  57 :         ipos(i) = i_z
  58 :  13   CONTINUE
  59 :       mm = ipos(np)
  60 :       ipos(nbpts) = mm
  61 : C Creation de ind
  62 :       SEGINI,ind
  63 : C Remplissage de ind
  64 :       DO 20 i = 1, NBELE1
  65 :         DO 21 j = 1, NBNN1
  66 :           ia = ipt1.num(j,i)
  67 :           ide=ipos(ia)
  68 :           ind(ide)=i  
  69 :           ipos(ia)=ide-1
  70 :  21     CONTINUE
  71 :  20   CONTINUE
  72 : 
  73 : * Remplissage de l'intersection
  74 :       I=0
  75 :       DO 1 i1 = 1, NBELE2
  76 :         ia=ipt2.num(1,i1)
  77 :         ideb=ipos(ia)+1
  78 :         ifin=ipos(ia+1)
  79 :         IF (ifin.lt.ideb) go to 1
  80 :         DO 2 ie=ideb,ifin
  81 :           iel=ind(ie) 
  82 :           DO 134 in1=1,NBNN1
  83 :             DO 136 in2=1,NBNN2
  84 :               IF(ipt1.num(in1,iel).EQ.ipt2.num(in2,i1)) GOTO 134
  85 :   136       CONTINUE
  86 :             GOTO 2
  87 :   134     CONTINUE
  88 : C       OK pour cet element
  89 :           I=I+1
  90 :           ICOLOR(I)=IPT1.ICOLOR(Iel)
  91 :           DO 135 J=1,NBNN
  92 :             NUM(J,I)=IPT1.NUM(J,iel)
  93 :  135      CONTINUE
  94 :           GOTO 1
  95 :  2      CONTINUE
  96 :  1    CONTINUE
  97 : 
  98 :       SEGSUP,ipos,ind
  99 : 
 100 :       NBELEM = I
 101 :       IF (NBELEM.EQ.0) THEN
 102 :         SEGSUP,MELEME
 103 :         IPT3 = 0
 104 :       ELSE
 105 :         SEGADJ,MELEME
 106 : C*        SEGDES,MELEME     <- Segment cree actif en sortie
 107 :         IPT3 = MELEME
 108 :       ENDIF
 109 : 
 110 :  900  CONTINUE
 111 : C*      SEGDES,IPT1,IPT2  <- Segments actifs en Sortie (non modifies)
 112 : 
 113 :       RETURN
 114 :       END
 115 : 
 116 :