C FUSE SOURCE CB215821 19/07/30 21:16:40 10273 SUBROUTINE FUSE(IPT1,IPT2,IPT3,LTELQ) C============================================================= C C Ce sous-programme réalise l'operation "ET" sur les deux objets C maillages IPT1 et IPT2. C Le resultat est rangé dans IPT3 C C============================================================= C C Modifications : C C PM 09/10/2007 : respecte l'ordre y compris avec éléments C dégénérés (points doubles) C CB215821 21/04/2015 : retrait des MAILLAGES vides éventuels durant C la fusion C C============================================================= C C Remarques : C C============================================================= IMPLICIT INTEGER(I-N) -INC PPARAM -INC CCOPTIO -INC CCGEOME -INC SMELEME LOGICAL LTELQ SEGMENT ISO1(NBSOU1) SEGMENT ISO2(NBSOU2) ITEMP=0 C Aiguillage C ---------- C Cas de deux maillages identiques ** Rien de special, on fait la fusion. Si on souhaite autre chose, on utilise UNIQ. ** IF (IPT1.GT.0.AND.IPT2.EQ.IPT1) THEN ** IPT3 = IPT1 ** RETURN ** ENDIF C Deux maillages différents SEGACT IPT1,IPT2 ISAUV1=IPT1 ISAUV2=IPT2 C Premier maillage complexe IF (IPT1.LISOUS(/1).NE.0) GOTO 100 C Seul le 2e maillage est complexe IF (IPT2.LISOUS(/1).NE.0) GOTO 101 C Deux maillages simples IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) GOTO 50 C 1) Deux maillages simples de même type C -------------------------------------- C CAS DES MULTIPLICATEURS: le nb de points par élément est différent IF (IPT1.NUM(/1).NE.IPT2.NUM(/1)) GOTO 50 C 1) Deux maillages simples de même type de même nb de points par élément IF (KSURF(IPT1.ITYPEL).NE.0) GOTO 70 C a) Deux objets de type ligne ou point CALL FUSELI(IPT1,IPT2,IPT3,LTELQ) GOTO 200 70 IF (KSURF(IPT1.ITYPEL).NE.IPT1.ITYPEL) GOTO 71 C b) Deux objets surfaciques CALL FUSESU(IPT1,IPT2,IPT3,LTELQ) GOTO 200 C c) Deux objets volumiques 71 CALL FUSEVO(IPT1,IPT2,IPT3,LTELQ) 200 RETURN C 2) Deux maillages simples de type ou de nb d'éléments différents C ---------------------------------------------------------------- 50 CONTINUE C Exclusion des MAILLAGES VIDES IF (IPT1.NUM(/2) .EQ. 0) THEN C Premier MAILLAGE VIDE C WRITE(IOIMP,*)'Premier MAILLAGE VIDE' SEGINI,IPT3=IPT2 ELSEIF (IPT2.NUM(/2) .EQ. 0) THEN C Deuxieme MAILLAGE VIDE C WRITE(IOIMP,*)'Deuxieme MAILLAGE VIDE' SEGINI,IPT3=IPT1 ELSE NBSOUS= 2 NBREF = 0 NBNN = 0 NBELEM= 0 SEGINI IPT3 IPT3.LISOUS(1)=IPT1 IPT3.LISOUS(2)=IPT2 ENDIF RETURN C 3) Un seul maillage complexe C ---------------------------- C qu'on s'arrange pour être le deuxième, C mais ITEMP<>0 permet de savoir qu'on les a intervertis 100 CONTINUE IF (IPT2.LISOUS(/1).NE.0) GOTO 110 ITEMP=IPT1 IPT1=IPT2 IPT2=ITEMP 101 CONTINUE C Cas du 1er MAILLAGE VIDE, on renvoie IPT3 comme une copie de IPT2 IF (IPT1.NUM(/2) .EQ. 0) THEN SEGINI,IPT3=IPT2 RETURN ENDIF NBSOU2=IPT2.LISOUS(/1) DO I=1,NBSOU2 IPT3=IPT2.LISOUS(I) SEGACT IPT3 IF (IPT3.NUM(/1).EQ.IPT1.NUM(/1)) THEN C une partition du bon type existe déjà IF (IPT3.ITYPEL.EQ.IPT1.ITYPEL) THEN IPT5=IPT1 IPT6=IPT3 if(ltelq)then IF (ITEMP.ne.0) THEN IPT5=IPT3 IPT6=IPT1 ENDIF endif GOTO 301 ENDIF ENDIF ENDDO C on ajoute au 2e une partition avec ce nouveau type d'élément NBSOUS = NBSOU2+1 NBREF = 0 NBNN = 0 NBELEM = 0 SEGINI IPT3 DO I=1,NBSOU2 IPT3.LISOUS(I)=IPT2.LISOUS(I) ENDDO IPT3.LISOUS(NBSOUS)=IPT1 RETURN C On fusionne le 1er avec la partition existante du 2e 301 CONTINUE IF (KSURF(IPT1.ITYPEL).EQ.0) THEN CALL FUSELI(IPT5,IPT6,IPT4,LTELQ) ELSEIF (KSURF(IPT1.ITYPEL).EQ.IPT1.ITYPEL) THEN CALL FUSESU(IPT5,IPT6,IPT4,LTELQ) ELSE CALL FUSEVO(IPT5,IPT6,IPT4,LTELQ) ENDIF NBSOUS = NBSOU2 NBREF = 0 NBNN = 0 NBELEM = 0 SEGINI IPT3 DO II=1,NBSOU2 IPT3.LISOUS(II)=IPT2.LISOUS(II) ENDDO IPT3.LISOUS(I)=IPT4 RETURN C 4) Deux maillages complexes C --------------------------- 110 CONTINUE NBSOU1=IPT1.LISOUS(/1) NBSOU2=IPT2.LISOUS(/1) NBSOUS=NBSOU1+NBSOU2 SEGINI ISO1,ISO2 DO I=1,NBSOU1 ISO1(I)=IPT1.LISOUS(I) ENDDO DO I=1,NBSOU2 ISO2(I)=IPT2.LISOUS(I) ENDDO C-- Fusion des partitions de mêmes caractéristiques DO I1=1,NBSOU1 IPT1=ISO1(I1) SEGACT IPT1 DO 311 I2=1,NBSOU2 SEGACT IPT1 IPT2=ISO2(I2) IF (IPT2.EQ.0) GOTO 311 SEGACT IPT2 IF (IPT1.ITYPEL.NE.IPT2.ITYPEL) GOTO 312 IF (IPT1.NUM(/1).NE.IPT2.NUM(/1)) GOTO 312 C On peut fusionner IF (KSURF(IPT1.ITYPEL).EQ.0) # CALL FUSELI(IPT1,IPT2,IPT3,LTELQ) IF (KSURF(IPT1.ITYPEL).NE.0.AND. # KSURF(IPT1.ITYPEL).NE.IPT1.ITYPEL) # CALL FUSEVO(IPT1,IPT2,IPT3,LTELQ) IF (KSURF(IPT1.ITYPEL).EQ.IPT1.ITYPEL) $ CALL FUSESU(IPT1,IPT2,IPT3,LTELQ) ISO1(I1)=IPT3 ISO2(I2)=0 NBSOUS=NBSOUS-1 312 CONTINUE 311 CONTINUE ENDDO C-- Gestion des sous-références (en évitant les redondances) NBREF = 0 IPT1 = ISAUV1 IPT2 = ISAUV2 SEGACT IPT1,IPT2 C POUR LE CAS DES VOLUMES ET DES SURFACES SI UN DES DEUX UNE SEULE C REFERENCE ON FAIT LA DIFFERENCE SYMETRIQUE C SI LES DEUX 2 OU 3 REFERENCE 1<-1.1 2<-2.2 3<-DIFF DES AUTRES C SI 1.2=2.1 IF (IPT1.LISREF(/1).EQ.0.OR.IPT2.LISREF(/1).EQ.0) GOTO 1000 IF (IPT1.LISREF(/1).EQ.1.OR.IPT2.LISREF(/1).EQ.1) THEN NBREF=1 GOTO 1001 ENDIF C Chaque maillage a au moins deux sous-références IPT3=IPT1.LISREF(2) IPT4=IPT2.LISREF(1) IF (IPT3.EQ.IPT4) GOTO 1002 SEGACT IPT3,IPT4 IF (IPT3.LISOUS(/1).EQ.0 .OR. # IPT3.LISOUS(/1).NE.IPT4.LISOUS(/1)) GOTO 1001 DO I=1,IPT3.LISOUS(/1) IF (IPT3.LISOUS(I).NE.IPT4.LISOUS(I)) GOTO 1001 ENDDO 1002 CONTINUE C Deux sous-réf. chaque dont au moins 1 commune NBREF=3 IF (IPT1.LISREF(/1).EQ.2 .OR. IPT2.LISREF(/1).EQ.2) THEN NBREF=2 GOTO 1011 ENDIF C A REVOIR NE MARCHE QUE SI LE POURTOUR EST FORME D'UN TYPE D'ELEMENT IPT3=IPT1.LISREF(3) SEGACT IPT3 IF (IPT1.LISREF(/1).EQ.3) GOTO 1004 DO 1005 I=4,IPT1.LISREF(/1) IPT4=IPT1.LISREF(I) SEGACT IPT4 IF (IPT4.NUM(/2).NE.0) GOTO 1006 NBREF=2 GOTO 1011 1006 IF (KSURF(IPT4.ITYPEL).EQ.0) CALL FUSELI(IPT3,IPT4,IPT5,LTELQ) IF (KSURF(IPT4.ITYPEL).NE.0) CALL FUSESU(IPT3,IPT4,IPT5,LTELQ) IPT3=IPT5 1005 CONTINUE 1004 CONTINUE IPT6=IPT2.LISREF(3) SEGACT IPT6 IF (IPT2.LISREF(/1).EQ.3) GOTO 1010 DO 1009 I=4,IPT2.LISREF(/1) IPT4=IPT2.LISREF(I) SEGACT IPT4 IF (IPT4.NUM(/2).NE.0) GOTO 1008 NBREF=2 GOTO 1011 1008 IF (KSURF(IPT4.ITYPEL).EQ.0) CALL FUSELI(IPT6,IPT4,IPT5,LTELQ) IF (KSURF(IPT4.ITYPEL).NE.0) CALL FUSESU(IPT6,IPT4,IPT5,LTELQ) IPT6=IPT5 1009 CONTINUE 1010 CONTINUE CALL OUEXCL(IPT3,IPT6,IPT7) GOTO 1011 1001 CONTINUE C ON EST SENSE TOUT FUSIONNER A VOIR PLUS TARD NBREF=0 1011 CONTINUE C-- Construction du maillage final et de ses sous-références 1000 CONTINUE NBNN = 0 NBELEM = 0 SEGINI IPT3 DO I=1,NBSOU1 IPT3.LISOUS(I)=ISO1(I) ENDDO II=NBSOU1+1 DO 112 I=1,NBSOU2 C on n'ajoute que les partitions n'existant pas encore IF (ISO2(I).EQ.0) GOTO 112 IPT3.LISOUS(II)=ISO2(I) II=II+1 112 CONTINUE SEGSUP ISO1,ISO2 IF (NBREF.EQ.0) GOTO 1020 IPT3.LISREF(1)=IPT1.LISREF(1) IPT3.LISREF(2)=IPT2.LISREF(2) IF (NBREF.EQ.2) GOTO 1020 IPT3.LISREF(3)=IPT7 1020 RETURN END