Télécharger la plaquette Cast3M


fr en

Télécharger fuse.eso

Retour à la liste

Numérotation des lignes : 

fuse

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

© Cast3M 2003 - Tous droits réservés.
Mentions légales