Esope source files

   1 : C FUSE      SOURCE    CHAT      07/10/31    16:40:18     5941           
   2 :       SUBROUTINE FUSE(IPT1,IPT2,IPT3,LTELQ)
   3 : *=============================================================
   4 : *
   5 : * Ce sous-programme réalise l'operation "ET" sur les deux objets
   6 : * maillages IPT1 et IPT2.
   7 : * Le resultat est rangé dans IPT3
   8 : *
   9 : *=============================================================
  10 : *
  11 : * Modifications :
  12 : *
  13 : *   PM 09/10/2007 : respecte l'ordre y compris avec éléments
  14 : *                   dégénérés (points doubles)
  15 : *
  16 : *=============================================================
  17 : *
  18 : * Remarques :
  19 : *
  20 : *=============================================================
  21 : 
  22 :       IMPLICIT INTEGER(I-N)
  23 : -INC CCOPTIO
  24 : -INC CCGEOME
  25 : -INC SMELEME
  26 :       LOGICAL LTELQ
  27 :       SEGMENT ISO1(NBSOU1)
  28 :       SEGMENT ISO2(NBSOU2)
  29 : 
  30 :       ITEMP=0
  31 : 
  32 : *     Aiguillage
  33 : *     ----------
  34 : *     Cas de deux maillages identiques
  35 :       IF (IPT1.GT.0.AND.IPT2.EQ.IPT1) THEN
  36 :          IPT3 = IPT1
  37 :          RETURN
  38 :       ENDIF
  39 : 
  40 : *     Deux maillages différents
  41 :       SEGACT IPT1,IPT2
  42 :       ISAUV1=IPT1
  43 :       ISAUV2=IPT2
  44 : 
  45 : *     Premier maillage complexe
  46 :       IF (IPT1.LISOUS(/1).NE.0) GOTO 100
  47 : *     Seul le 2e maillage est complexe
  48 :       IF (IPT2.LISOUS(/1).NE.0) GOTO 101
  49 : *     Deux maillages simples
  50 :       IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) GOTO 50
  51 : 
  52 : *     1) Deux maillages simples de même type
  53 : *     --------------------------------------
  54 : *     CAS DES MULTIPLICATEURS: le nb de points par élément est différent
  55 :       IF (IPT1.NUM(/1).NE.IPT2.NUM(/1)) GOTO 50
  56 : 
  57 : *     1) Deux maillages simples de même type de même nb de points par élément
  58 :       IF (KSURF(IPT1.ITYPEL).NE.0) GOTO 70
  59 : *     a) Deux objets de type ligne ou point
  59 :       CALL FUSELI(IPT1,IPT2,IPT3,LTELQ)
  60 :       GOTO 200 
  61 : 
  62 :   70  IF (KSURF(IPT1.ITYPEL).NE.IPT1.ITYPEL) GOTO 71
  63 : *     b) Deux objets surfaciques
  63 :       CALL FUSESU(IPT1,IPT2,IPT3,LTELQ)
  64 :       GOTO 200
  65 : 
  66 : *     c) Deux objets volumiques
  66 :   71  CALL FUSEVO(IPT1,IPT2,IPT3,LTELQ)
  67 : 
  68 :  200  SEGDES IPT1,IPT2,IPT3
  69 :       RETURN
  70 : 
  71 : *     2) Deux maillages simples de type ou de nb d'éléments différents
  72 : *     ----------------------------------------------------------------
  73 :   50  CONTINUE
  74 :       NBSOUS= 2
  75 :       NBREF = 0
  76 :       NBNN  = 0
  77 :       NBELEM= 0
  78 :       SEGINI IPT3
  79 :       IPT3.LISOUS(1)=IPT1
  80 :       IPT3.LISOUS(2)=IPT2
  81 :       SEGDES IPT1,IPT2,IPT3
  82 :       RETURN
  83 : 
  84 : *     3) Un seul maillage complexe
  85 : *     ----------------------------
  86 : *     qu'on s'arrange pour être le deuxième, 
  87 : *     mais ITEMP<>0 permet de savoir qu'on les a intervertis
  88 :  100  CONTINUE
  89 :       IF (IPT2.LISOUS(/1).NE.0) GOTO 110
  90 :       ITEMP=IPT1
  91 :       IPT1=IPT2
  92 :       IPT2=ITEMP
  93 :  101  CONTINUE
  94 : 
  95 :       NBSOU2=IPT2.LISOUS(/1)
  96 :       DO I=1,NBSOU2
  97 :          IPT3=IPT2.LISOUS(I)
  98 :          SEGACT IPT3
  99 :          IF (IPT3.NUM(/1).EQ.IPT1.NUM(/1)) THEN
 100 : *           une partition du bon type existe déjà
 101 :             IF (IPT3.ITYPEL.EQ.IPT1.ITYPEL) THEN
 102 :                IPT5=IPT1
 103 :                IPT6=IPT3            
 104 :                if(ltelq)then
 105 :                  IF (ITEMP.ne.0) THEN                   
 106 :                   IPT5=IPT3
 107 :                   IPT6=IPT1
 108 :                  ENDIF 
 109 :                endif           
 110 :                GOTO 301
 111 :             ENDIF 
 112 :          ENDIF
 113 :          SEGDES IPT3
 114 :       ENDDO 
 115 : *     on ajoute au 2e une partition avec ce nouveau type d'élément
 116 :       NBSOUS = NBSOU2+1
 117 :       NBREF  = 0
 118 :       NBNN   = 0
 119 :       NBELEM = 0
 120 :       SEGINI IPT3
 121 :       DO I=1,NBSOU2
 122 :          IPT3.LISOUS(I)=IPT2.LISOUS(I)
 123 :       ENDDO
 124 :       IPT3.LISOUS(NBSOUS)=IPT1
 125 :       SEGDES IPT1,IPT2,IPT3
 126 :       RETURN
 127 : 
 128 : *     On fusionne le 1er avec la partition existante du 2e
 129 :  301  CONTINUE 
 130 :       IF (KSURF(IPT1.ITYPEL).EQ.0) THEN
 130 :          CALL FUSELI(IPT5,IPT6,IPT4,LTELQ)
 131 :       ELSEIF (KSURF(IPT1.ITYPEL).EQ.IPT1.ITYPEL) THEN
 131 :          CALL FUSESU(IPT5,IPT6,IPT4,LTELQ)
 132 :       ELSE
 132 :          CALL FUSEVO(IPT5,IPT6,IPT4,LTELQ)
 133 :       ENDIF 
 134 :       SEGDES IPT1,IPT3
 135 :       SEGDES IPT4
 136 :       NBSOUS = NBSOU2
 137 :       NBREF  = 0
 138 :       NBNN   = 0
 139 :       NBELEM = 0
 140 :       SEGINI IPT3
 141 :       DO II=1,NBSOU2
 142 :          IPT3.LISOUS(II)=IPT2.LISOUS(II)
 143 :       ENDDO 
 144 :       IPT3.LISOUS(I)=IPT4
 145 :       SEGDES IPT2
 146 :       SEGDES IPT3
 147 :       RETURN
 148 : 
 149 : *     4) Deux maillages complexes
 150 : *     ---------------------------
 151 :  110  CONTINUE
 152 :       NBSOU1=IPT1.LISOUS(/1)
 153 :       NBSOU2=IPT2.LISOUS(/1)
 154 :       NBSOUS=NBSOU1+NBSOU2
 155 :       SEGINI ISO1,ISO2
 156 :       DO I=1,NBSOU1
 157 :          ISO1(I)=IPT1.LISOUS(I)
 158 :       ENDDO 
 159 :       DO I=1,NBSOU2
 160 :          ISO2(I)=IPT2.LISOUS(I)
 161 :       ENDDO 
 162 :       SEGDES IPT1,IPT2
 163 : 
 164 : *--   Fusion des partitions de mêmes caractéristiques
 165 :       DO I1=1,NBSOU1
 166 :          IPT1=ISO1(I1)
 167 :          SEGACT IPT1
 168 :          DO 311 I2=1,NBSOU2
 169 :             SEGACT IPT1
 170 :             IPT2=ISO2(I2)
 171 :             IF (IPT2.EQ.0) GOTO 311
 172 :             SEGACT IPT2
 173 :             IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) GOTO 312
 174 :             IF (IPT1.NUM(/1).NE.IPT2.NUM(/1)) GOTO 312
 175 : *           On peut fusionner
 176 :             IF (KSURF(IPT1.ITYPEL).EQ.0) 
 176 :      #          CALL FUSELI(IPT1,IPT2,IPT3,LTELQ)
 177 :             IF (KSURF(IPT1.ITYPEL).NE.0.AND.
 178 :      #          KSURF(IPT1.ITYPEL).NE.IPT1.ITYPEL) 
 178 :      #          CALL FUSEVO(IPT1,IPT2,IPT3,LTELQ)
 179 :             IF (KSURF(IPT1.ITYPEL).EQ.IPT1.ITYPEL) 
 179 :      $          CALL FUSESU(IPT1,IPT2,IPT3,LTELQ)
 180 :             ISO1(I1)=IPT3
 181 :             ISO2(I2)=0
 182 :             SEGDES IPT3
 183 :             NBSOUS=NBSOUS-1
 184 :  312        CONTINUE
 185 :             SEGDES IPT2
 186 :  311     CONTINUE
 187 :          SEGDES IPT1
 188 :       ENDDO
 189 : 
 190 : *--   Gestion des sous-références (en évitant les redondances)
 191 :       NBREF = 0
 192 :       IPT1  = ISAUV1
 193 :       IPT2  = ISAUV2
 194 :       SEGACT IPT1,IPT2
 195 : C     POUR LE CAS DES VOLUMES ET DES SURFACES  SI UN DES DEUX UNE SEULE
 196 : C     REFERENCE ON FAIT LA DIFFERENCE SYMETRIQUE
 197 : C     SI LES DEUX 2 OU 3 REFERENCE 1<-1.1  2<-2.2  3<-DIFF DES AUTRES
 198 : C                     SI 1.2=2.1
 199 :       IF (IPT1.LISREF(/1).EQ.0.OR.IPT2.LISREF(/1).EQ.0) GOTO 1000
 200 :       IF (IPT1.LISREF(/1).EQ.1.OR.IPT2.LISREF(/1).EQ.1) THEN
 201 :          NBREF=1
 202 :          GOTO 1001
 203 :       ENDIF 
 204 : C     Chaque maillage a au moins deux sous-références
 205 :       IPT3=IPT1.LISREF(2)
 206 :       IPT4=IPT2.LISREF(1)
 207 :       IF (IPT3.EQ.IPT4) GOTO 1002
 208 :       SEGACT IPT3,IPT4
 209 :       IF (IPT3.LISOUS(/1).EQ.0 .OR.
 210 :      #    IPT3.LISOUS(/1).NE.IPT4.LISOUS(/1)) GOTO 1001
 211 :       DO I=1,IPT3.LISOUS(/1)
 212 :          IF (IPT3.LISOUS(I).NE.IPT4.LISOUS(I)) GOTO 1001
 213 :       ENDDO 
 214 :       SEGDES IPT3,IPT4
 215 : 
 216 :  1002 CONTINUE
 217 : C     Deux sous-réf. chaque dont au moins 1 commune
 218 :       NBREF=3
 219 :       IF (IPT1.LISREF(/1).EQ.2 .OR. IPT2.LISREF(/1).EQ.2) THEN 
 220 :          NBREF=2
 221 :          GOTO 1011
 222 :       ENDIF 
 223 : C     A REVOIR NE MARCHE QUE SI LE POURTOUR EST FORME D'UN TYPE D'ELEMENT
 224 :       IPT3=IPT1.LISREF(3)
 225 :       SEGACT IPT3
 226 :       IF (IPT1.LISREF(/1).EQ.3) GOTO 1004
 227 :       DO 1005 I=4,IPT1.LISREF(/1)
 228 :          IPT4=IPT1.LISREF(I)
 229 :          SEGACT IPT4
 230 :          IF (IPT4.NUM(/2).NE.0) GOTO 1006
 231 :          NBREF=2
 232 :          SEGDES IPT4
 233 :          GOTO 1011
 233 :  1006    IF (KSURF(IPT4.ITYPEL).EQ.0) CALL FUSELI(IPT3,IPT4,IPT5,LTELQ)
 233 :          IF (KSURF(IPT4.ITYPEL).NE.0) CALL FUSESU(IPT3,IPT4,IPT5,LTELQ)
 234 :          SEGDES IPT3,IPT4
 235 :          IPT3=IPT5
 236 :  1005 CONTINUE
 237 :  1004 CONTINUE
 238 :       IPT6=IPT2.LISREF(3)
 239 :       SEGACT IPT6
 240 :       IF (IPT2.LISREF(/1).EQ.3) GOTO 1010
 241 :       DO 1009 I=4,IPT2.LISREF(/1)
 242 :          IPT4=IPT2.LISREF(I)
 243 :          SEGACT IPT4
 244 :          IF (IPT4.NUM(/2).NE.0) GOTO 1008
 245 :          NBREF=2
 246 :          SEGDES IPT4
 247 :          GOTO 1011
 247 :  1008    IF (KSURF(IPT4.ITYPEL).EQ.0) CALL FUSELI(IPT6,IPT4,IPT5,LTELQ)
 247 :          IF (KSURF(IPT4.ITYPEL).NE.0) CALL FUSESU(IPT6,IPT4,IPT5,LTELQ)
 248 :          SEGDES IPT6,IPT4
 249 :          IPT6=IPT5
 250 :  1009 CONTINUE
 251 :  1010 CONTINUE
 251 :       CALL OUEXCL(IPT3,IPT6,IPT7)
 252 :       SEGDES IPT3,IPT6,IPT7
 253 :       GOTO 1011
 254 : 
 255 :  1001 CONTINUE
 256 : C     ON EST SENSE TOUT FUSIONNER A VOIR PLUS TARD
 257 :       NBREF=0
 258 : 
 259 :  1011 CONTINUE
 260 : 
 261 : *--   Construction du maillage final et de ses sous-références
 262 :  1000 CONTINUE
 263 :       NBNN   = 0
 264 :       NBELEM = 0
 265 :       SEGINI IPT3
 266 :       DO I=1,NBSOU1
 267 :          IPT3.LISOUS(I)=ISO1(I)
 268 :       ENDDO 
 269 :       II=NBSOU1+1
 270 :       DO 112 I=1,NBSOU2
 271 : *        on n'ajoute que les partitions n'existant pas encore
 272 :          IF (ISO2(I).EQ.0) GOTO 112
 273 :          IPT3.LISOUS(II)=ISO2(I)
 274 :          II=II+1
 275 :  112  CONTINUE
 276 :       SEGSUP ISO1,ISO2
 277 : 
 278 :       IF (NBREF.EQ.0) GOTO 1020
 279 :       IPT3.LISREF(1)=IPT1.LISREF(1)
 280 :       IPT3.LISREF(2)=IPT2.LISREF(2)
 281 :       IF (NBREF.EQ.2) GOTO 1020
 282 :       IPT3.LISREF(3)=IPT7
 283 : 
 284 :  1020 SEGDES IPT1,IPT2,IPT3
 285 :       RETURN
 286 : 
 287 :       END
 288 :  
 289 :  
 290 :