Télécharger la plaquette Cast3M


fr en

Télécharger part7.eso

Retour à la liste

Numérotation des lignes : 

part7

  1. C PART7     SOURCE    CB215821  24/04/12    21:16:50     11897          
  2. ************************************************************************
  3. * NOM         : PART7
  4. * DESCRIPTION : Sous-programme dedie a la separation en composantes
  5. *               connexes d'un maillage + regles supplementaires de
  6. *               separation en differentes zones
  7. ************************************************************************
  8. * APPELE PAR : part.eso ; ccon.eso (obsolete)
  9. ************************************************************************
  10. * ENTREES :: MEL1  = pointeur sur le maillage a partitionner
  11. *            KLI   > 0 si option 'LIGN'
  12. *            KFA   > 0 si option 'FACE'
  13. *            KMA   > 0 si option 'MAIL'
  14. *            MEL2  = pointeur sur le maillage separateur (option 'MAIL')
  15. *            KAN   > 0 si option 'ANGL'
  16. *            ANG   = valeur seuil pour l'angle (option 'ANGL')
  17. *            ITQ   > 0 si mot-cle 'TELQ' present (option 'ANGL')
  18. *            KESCL > 0 si besoin des indices SOUSTYPE et CREATEUR
  19. * SORTIES :: ITAB  = pointeur vers la table de partitionnement
  20. ************************************************************************
  21.       SUBROUTINE PART7(MEL1,KLI,KFA,KMA,MEL2,KAN,ANG,ITQ,ITAB,KESCL)
  22.  
  23.       IMPLICIT INTEGER(I-N)
  24.       IMPLICIT REAL*8 (A-H,O-Z)
  25.  
  26.  
  27. -INC PPARAM
  28. -INC CCOPTIO
  29. -INC CCGEOME
  30. -INC SMCOORD
  31. -INC SMELEME
  32. -INC SMTABLE
  33. -INC SMCHAML
  34. -INC SMMODEL
  35.  
  36.       SEGMENT JMEM(NODES+1)
  37. C     JMEM CONTIENT LE NOMBRE D'ELEMENTS AUQUEL APPARTIENT CHAQUE NOEUD
  38. C     PUIS LA POSITION DU PREMIER ELEMENT DANS IMEMO ET LMEMO
  39.  
  40.       SEGMENT ICPR(nbpts)
  41. C     ICPR(I) DONNE LE NUMERO LOCAL (DANS LES TABLEAUX DE LA PRESENTE
  42. C     SUBROUTINE) DU I-EME NOEUD GLOBAL (DANS LA TABLE MCOORD)
  43.  
  44.       SEGMENT IMEMO(NBV),LMEMO(NBV)
  45. C     CONTIENT LA LISTE DES ELEMENTS APPARTENANT AU NOEUD 1, 2, 3...
  46. C     (IMEMO => NUMERO DE L'ELEMENT ET LMEMO => NUMERO DU LISOUS)
  47.  
  48.       SEGMENT LISIND(NBS)
  49. C     POINTE VERS LES SEGMENTS INDIC ASSOCIES A CHAQUE SOUS-MAILLAGE
  50.  
  51.       SEGMENT JMEM2(NODES2+1),ICPR2(nbpts),IMEMO2(NBV2),
  52.      &        LMEMO2(NBV2)
  53. C     IDEM, MAIS POUR LE MAILLAGE SEPARATEUR
  54.  
  55.       SEGMENT INDIC(NBEL)
  56. C     INDICATEUR DU NUMERO DE ZONE
  57.  
  58.       SEGMENT LISCO1(NELTOT),LISCO2(NELTOT)
  59. C     LISTES DES ELEMENTS VOISINS
  60.  
  61.       SEGMENT LISIN(NNOMAX)
  62. C     LISTE DES NOEUDS A L'INTERFACE ENTRE DEUX ELEMENTS VOISINS
  63.  
  64.       SEGMENT MIELVA
  65.          INTEGER IELVAX(N1)
  66.          INTEGER IELVAY(N1)
  67.          INTEGER IELVAZ(N1)
  68.       ENDSEGMENT
  69. C     POINTEURS VERS LES SEGMENTS MELVAL (OPTION 'ANGL')
  70.  
  71.       LOGICAL KDIM1,KDIM2,KDIM3
  72.       INTEGER NNOMAX
  73.  
  74.  
  75.  
  76.  
  77. *     +---------------------------------------------------------------+
  78. *     |                                                               |
  79. *     |                 I N I T I A L I S A T I O N S                 |
  80. *     |                                                               |
  81. *     +---------------------------------------------------------------+
  82.  
  83.  
  84.  
  85. *     VERIFICATION QUE LE MAILLAGE EST COMPATIBLE AVEC LES OPTIONS
  86. *     FOURNIES
  87. *     ************************************************************
  88.       NNOMAX=0
  89.       MELEME=MEL1
  90.       SEGACT,MELEME
  91.       IPT1=MELEME
  92.  
  93.       IDIM1=0
  94.       IDIM2=0
  95.       IDIM3=0
  96.       DO ISO=1,MAX(1,LISOUS(/1))
  97.          IF (LISOUS(/1).GT.1) THEN
  98.             IPT1=LISOUS(ISO)
  99.             SEGACT,IPT1
  100.          ENDIF
  101.  
  102.          ITY=IPT1.ITYPEL
  103.          NNOMAX=MAX(NNOMAX,NBNNE(ITY))
  104.  
  105. *         KDIM1=(LDLR(ITY).EQ.1.AND.ITY.NE.12.AND.ITY.NE.13)
  106. *         KDIM2=(ITY.EQ.KSURF(ITY))
  107. *         KDIM3=(LDLR(ITY).EQ.3.AND.ITY.NE.30.AND.ITY.NE.31)
  108.          KDIM1=(LDLR(ITY).EQ.1)
  109.          KDIM2=(LDLR(ITY).EQ.2)
  110.          KDIM3=(LDLR(ITY).EQ.3)
  111.  
  112. *        Element special type 'MULT' ou 'SUPE'
  113.          IF (.NOT.(KDIM1.OR.KDIM2.OR.KDIM3)) THEN
  114.             CALL ERREUR(16)
  115.             RETURN
  116.          ENDIF
  117.  
  118.          IF (KDIM1) IDIM1=IDIM1+1
  119.          IF (KDIM2) IDIM2=IDIM2+1
  120.          IF (KDIM3) IDIM3=IDIM3+1
  121.       ENDDO
  122.  
  123.       IF ((KFA.GT.0.AND.(IDIM1.GT.0.OR.IDIM3.GT.0)).OR.
  124.      &    (KLI.GT.0.AND.(IDIM2.GT.0.OR.IDIM3.GT.0)).OR.
  125.      &    (KAN.GT.0.AND.IDIM3.GT.0)) THEN
  126.          CALL ERREUR(16)
  127.          RETURN
  128.       ENDIF
  129.  
  130.  
  131. *     OPTION 'ANGL' => CREATION DES TABLEAUX DONNANT LE VECTEUR
  132. *     NORMAL/TANGENT A CHAQUE ELEMENT
  133. *     *********************************************************
  134.  
  135.       IF (KAN.GT.0) THEN
  136.  
  137. *        Transformation en un maillage lineaire
  138.          CALL ECROBJ('MAILLAGE',MELEME)
  139.          CALL CHANLI 
  140.          IF (IERR.NE.0) RETURN
  141.          CALL LIROBJ('MAILLAGE',MELEME,1,IRET)
  142.          IF (IERR.NE.0) RETURN         
  143.  
  144. *        Creation d'un objet MMODEL temporaire (le type est sans
  145. *        importance)
  146.          CALL ECRCHA('POUT')
  147.          CALL ECRCHA('COQ4')
  148.          CALL ECRCHA('COQ3')
  149.          CALL ECRCHA('ELASTIQUE')
  150.          CALL ECRCHA('MECANIQUE')
  151.          CALL ECROBJ('MAILLAGE',MELEME)
  152.          CALL MODELI         
  153.          IF (IERR.NE.0) RETURN
  154.          CALL LIROBJ('MMODEL  ',IPMODL,1,IRET)
  155.          CALL ACTOBJ('MMODEL  ',IPMODL,1)
  156.          IF (IERR.NE.0) RETURN
  157.  
  158. *        Calcul des vecteurs directeurs
  159.          SEGACT,MCOORD
  160.          CALL JACONO(IPMODL,1,IPCHE5,IRET)
  161.          IF (IERR.NE.0) RETURN
  162.  
  163. *        On ne garde qu'une seule valeur par element (=> type GRAVITE)
  164.          CALL CHASUP(IPMODL,IPCHE5,IPCHE2,IRET,2)
  165.          IF (IERR.NE.0) RETURN
  166.          IF (IRET.NE.0) THEN
  167.             CALL ERREUR(IRET)
  168.             RETURN
  169.          ENDIF
  170.  
  171. *        On recupere le MELEME pour etre sur d'avoir le bon ordre de
  172. *        description des elements
  173.          CALL ECRCHA('MAIL')
  174.          CALL ECROBJ('MCHAML',IPCHE2)
  175.          CALL EXTRAI
  176.          IF (IERR.NE.0) RETURN
  177.          CALL LIROBJ('MAILLAGE',MELEME,1,IRET)
  178.          IF (IERR.NE.0) RETURN
  179.  
  180. *        Suppression de l'objet MMODEL
  181.          MMODEL=IPMODL
  182.          SEGACT,MMODEL
  183.          DO K=1,KMODEL(/1)
  184.             IMODEL=KMODEL(K)
  185.             SEGSUP,IMODEL
  186.          ENDDO
  187.          SEGSUP,MMODEL
  188.  
  189. *        Remplissage du segment MIELVA (pointeurs vers les MELVAL)
  190.          MCHELM=IPCHE2
  191.          SEGACT,MCHELM
  192.          N1=ICHAML(/1)
  193.          SEGINI,MIELVA
  194.          DO I=1,N1
  195.             MCHAML=ICHAML(I)
  196.             SEGACT,MCHAML
  197.  
  198.             IELVAX(I)=IELVAL(1)
  199.             MELVAL=IELVAX(I)
  200.             SEGACT,MELVAL
  201.  
  202.             IELVAY(I)=IELVAL(2)
  203.             MELVAL=IELVAY(I)
  204.             SEGACT,MELVAL
  205.  
  206.             IF (IDIM.EQ.3) THEN
  207.                IELVAZ(I)=IELVAL(3)
  208.                MELVAL=IELVAZ(I)
  209.                SEGACT,MELVAL
  210.             ENDIF
  211.  
  212.             SEGSUP,MCHAML
  213.          ENDDO
  214.          SEGSUP,MCHELM
  215.  
  216.       ENDIF
  217.  
  218.  
  219. *     CORRESPONDANCE ENTRE LES NUMEROTATIONS LOCALE/GLOBALE
  220. *     *****************************************************
  221.  
  222.       SEGINI,ICPR
  223.  
  224.       SEGACT,MELEME
  225.       NBSOUS=LISOUS(/1)
  226.       NBS=MAX(1,NBSOUS)
  227.       IPT1=MELEME
  228.  
  229. *     Boucle sur les eventuels sous-maillages
  230.       IKOU=0
  231.       DO 100 IO=1,NBS
  232.          IF (NBSOUS.GT.0) THEN
  233.             IPT1=LISOUS(IO)
  234.             SEGACT,IPT1
  235.          ENDIF
  236.  
  237. *        Remplissage du tableau de correspondance ICPR
  238.          DO 150 J=1,IPT1.NUM(/2)
  239.          DO 150 I=1,IPT1.NUM(/1)
  240.             IJ=IPT1.NUM(I,J)
  241.             IF (ICPR(IJ).EQ.0) THEN
  242.               IKOU=IKOU+1
  243.               ICPR(IJ)=IKOU
  244.             ENDIF
  245. 150      CONTINUE
  246.  
  247. 100   CONTINUE
  248.  
  249. *     Nombre de noeuds distincts dans le maillage
  250.       NODES=IKOU
  251.  
  252. *     MAILLAGE vide => on sort des maintenant
  253.       IF (NODES.EQ.0) THEN
  254.          M=0
  255.          SEGINI,MTABLE
  256.          ITAB=MTABLE
  257.          MLOTAB=0
  258.          GOTO 9999
  259.       ENDIF
  260.  
  261. *
  262. *     IDENTIFICATION DES ELEMENTS OU APPARAISSENT TOUS LES NOEUDS
  263. *          =>  IMEMO = NUMERO DE ELEMENT
  264. *          =>  LMEMO = NUMERO DU SOUS-MAILLGE
  265. *     JMEM(I)+1 IDENTIFIE LA POSITION DANS IMEMO/LMEMO DU PREMIER
  266. *     ELEMENT ASSOCIE AU NOEUD I
  267. *     ***************************************************************
  268.  
  269.       SEGINI,JMEM
  270.  
  271. *     On compte combien de fois chaque noeud apparait dans le maillage
  272.       DO 200 IO=1,NBS
  273.          IF (NBSOUS.GT.0) IPT1=LISOUS(IO)
  274.          DO 250 J=1,IPT1.NUM(/2)
  275.          DO 250 I=1,IPT1.NUM(/1)
  276.             IJ=ICPR(IPT1.NUM(I,J))
  277.             JMEM(IJ)=JMEM(IJ)+1
  278. 250      CONTINUE
  279. 200   CONTINUE
  280. *     
  281. *     On en deduit par cumul la position de depart dans IMEMO/LMEMO
  282.       DO 290 I=1+1,NODES+1
  283.          JMEM(I)=JMEM(I)+JMEM(I-1)
  284. 290   CONTINUE
  285.       NBV=JMEM(NODES)
  286. *
  287. *     Remplissage de IMEMO et LMEMO
  288.       SEGINI,IMEMO,LMEMO
  289.       DO 300 IO=1,NBS
  290.          IF (NBSOUS.GT.0) IPT1=LISOUS(IO)
  291.          DO 350 J=1,IPT1.NUM(/2)
  292.          DO 350 I=1,IPT1.NUM(/1)
  293.              IJ=ICPR(IPT1.NUM(I,J))
  294.              IMEMO(JMEM(IJ))=J
  295.              LMEMO(JMEM(IJ))=IO
  296.              JMEM(IJ)=JMEM(IJ)-1
  297. 350      CONTINUE
  298. 300   CONTINUE
  299.  
  300.  
  301. *     OPTION 'MAIL' => ON REMPLIT DE LA MEME MANIERE ICPR2, JMEM2,
  302. *     IMEMO2 ET LMEMO2
  303. *     ************************************************************
  304.  
  305.       IF (KMA.GT.0) THEN       
  306.  
  307. *        Tableau ICPR2
  308.          SEGINI,ICPR2
  309.          IPT2=MEL2
  310.          SEGACT,IPT2
  311.          NBSOU2=IPT2.LISOUS(/1)
  312.          NBS2=MAX(1,NBSOU2)
  313.          IPT5=IPT2
  314.          IKOU=0
  315.          DO 400 IO=1,NBS2
  316.             IF (NBSOU2.GT.0) THEN
  317.                IPT5=IPT2.LISOUS(IO)
  318.                SEGACT,IPT5
  319.             ENDIF
  320.             DO 401 J=1,IPT5.NUM(/2)
  321.             DO 401 I=1,IPT5.NUM(/1)
  322.                IJ=IPT5.NUM(I,J)
  323.                IF (ICPR2(IJ).EQ.0) THEN
  324.                  IKOU=IKOU+1
  325.                  ICPR2(IJ)=IKOU
  326.                ENDIF
  327. 401         CONTINUE
  328. 400      CONTINUE
  329.          NODES2=IKOU
  330.  
  331. *        MAILLAGE vide => l'option 'MAIL' est desactivee
  332.          IF (NODES2.EQ.0) THEN
  333.             DO 410 IO=1,NBS2
  334.                IF (NBSOU2.GT.0) IPT5=IPT2.LISOUS(IO)
  335.                SEGDES,IPT5
  336. 410         CONTINUE
  337.             SEGSUP,ICPR2
  338.             KMA=0
  339.             GOTO 499
  340.          ENDIF
  341.  
  342. *        Tableaux JMEM2, IMEMO2 et LMEMO2
  343.          SEGINI,JMEM2
  344.          DO 420 IO=1,NBS2
  345.             IF (NBSOU2.GT.0) IPT5=IPT2.LISOUS(IO)
  346.             DO 421 J=1,IPT5.NUM(/2)
  347.             DO 421 I=1,IPT5.NUM(/1)
  348.                IJ=ICPR2(IPT5.NUM(I,J))
  349.                JMEM2(IJ)=JMEM2(IJ)+1
  350. 421         CONTINUE
  351. 420      CONTINUE
  352.          DO 430 I=1+1,NODES2+1
  353.             JMEM2(I)=JMEM2(I)+JMEM2(I-1)
  354. 430      CONTINUE
  355.          NBV2=JMEM2(NODES2)
  356.          SEGINI,IMEMO2,LMEMO2
  357.          DO 440 IO=1,NBS2
  358.             IF (NBSOU2.GT.0) IPT5=IPT2.LISOUS(IO)
  359.             DO 441 J=1,IPT5.NUM(/2)
  360.             DO 441 I=1,IPT5.NUM(/1)
  361.                 IJ=ICPR2(IPT5.NUM(I,J))
  362.                 IMEMO2(JMEM2(IJ))=J
  363.                 LMEMO2(JMEM2(IJ))=IO
  364.                 JMEM2(IJ)=JMEM2(IJ)-1
  365. 441         CONTINUE
  366. 440      CONTINUE
  367.  
  368. *        On cree aussi le segment LISIN qui servira plus bas
  369.          SEGINI,LISIN
  370.  
  371.       ENDIF   
  372. 499   CONTINUE
  373.  
  374.  
  375. *     CREATION D'UN SEGMENT INDIC POUR CHAQUE LISOUS
  376. *     **********************************************
  377.  
  378.       SEGINI,LISIND
  379.       NELTOT=0
  380.       DO 500 IO=1,NBS
  381.          IF (NBSOUS.NE.0) IPT1=LISOUS(IO)
  382.          NBEL=IPT1.NUM(/2)
  383.          NELTOT=NELTOT+NBEL
  384.          SEGINI,INDIC
  385.          LISIND(IO)=INDIC
  386.  500  CONTINUE
  387.       SEGINI LISCO1,LISCO2
  388.  
  389.  
  390.  
  391. *     +---------------------------------------------------------------+
  392. *     |                                                               |
  393. *     |          C O N S T R U C T I O N   D E S   Z O N E S          |
  394. *     |                                                               |
  395. *     +---------------------------------------------------------------+
  396.  
  398.       IOC=1
  399.       IELC=0
  400.  
  401. *     LABEL 1000 : PARCOURS DES SEGMENTS INDIC A LA RECHERCHE D'UN
  402. *                  ELEMENT ENCORE NON ATTRIBUE
  403. *     ************************************************************
  404. 1000  CONTINUE
  405.  
  407.       IELC=IELC+1
  408.       DO 1010 IO=IOC,NBS
  409.          IF (NBSOUS.NE.0) IPT1=LISOUS(IO)
  410.          INDIC=LISIND(IO)
  411.          DO 1020 IEL=IELC,IPT1.NUM(/2)
  412.             IF (INDIC(IEL).EQ.0) GOTO 1030
  413. 1020     CONTINUE
  414.          IELC=1
  415. 1010  CONTINUE
  416.  
  417. C     TOUS LES ELEMENTS ONT ETE CLASSES => ON A FINI
  418.       GOTO 1500
  419.  
  420. *     ON A TROUVE UN ELEMENT DE DEPART D'UNE NOUVELLE ZONE
  421. *     => ON VA ETENDRE AUX ELEMENTS VOISINS
  422. *     ****************************************************
  423. 1030  CONTINUE
  424.       IOC=IO
  425.       IELC=IEL
  426.  
  427. *     On attribue une zone a l'element trouve
  429.  
  430. *     ILRMP = Nombre d'elements ajoutes a LISCO1/LISCO2
  431. *     ILEXT = Nombre d'elements parcourus dans LISCO1/LISCO2
  432.       ILRMP=1
  433.       ILEXT=1
  434.  
  435. *     On reinitialise LISCO1/LISCO2 avec seulement cet element
  436.       LISCO1(ILRMP)=IO
  437.       LISCO2(ILRMP)=IEL
  438.  
  439. *     BOUCLE DE REMPLISSAGE DE LISCO1/LISCO2, DE VOISIN EN VOISIN
  440. *     ***********************************************************
  441.  
  442. *     Label 1120 => element suivant dans les listes LISCO1/LISCO2
  443. 1120  CONTINUE
  444.       IF (ILEXT.GT.ILRMP) GOTO 1130
  445.  
  446.       ION=LISCO1(ILEXT)
  447.       IEL=LISCO2(ILEXT)
  448.       IF (NBSOUS.NE.0) IPT1=LISOUS(ION)
  449.       IF (KAN.GT.0) THEN
  450. *        Vecteur directeur de l'element 1 (option 'ANGL')
  451.          MELVAL=IELVAX(ION)
  452.          IELMIN=MIN(IEL,MELVAL.VELCHE(/2))
  453.          X1=VELCHE(1,IELMIN)           
  454.          MELVAL=IELVAY(ION)
  455.          IELMIN=MIN(IEL,MELVAL.VELCHE(/2))
  456.          Y1=VELCHE(1,IELMIN)
  457.          IF (IDIM.EQ.3) THEN
  458.             MELVAL=IELVAZ(ION)
  459.             IELMIN=MIN(IEL,MELVAL.VELCHE(/2))
  460.             Z1=VELCHE(1,IELMIN)
  461.          ENDIF
  462.       ENDIF
  463.  
  464. *     Label 1100 => noeud IP suivant de l'element courant
  465.       DO 1100 IN=1,IPT1.NUM(/1)
  466.          IP=ICPR(IPT1.NUM(IN,IEL))
  467.  
  468. *        Label 1110 => voisin suivant via le noeud IP
  469.          DO 1110 KK=JMEM(IP)+1,JMEM(IP+1)
  470.             JON=LMEMO(KK)
  471.             JEL=IMEMO(KK)
  472.             INDIC=LISIND(JON)
  473.  
  474.  
  475. *           TESTS SUR L'ELEMENT VOISIN (JON;JEL) : SI L'UN DES TESTS
  476. *           ECHOUE, ALORS CET ELEMENT N'APPARTIENT PAS A CETTE ZONE
  477. *           ********************************************************
  478.  
  479. *           1) CONDITION SINE QUA NONE : IL N'A PAS DEJA ETE ATTRIBUE
  480. *              A UNE AUTRE ZONE
  481. *              ======================================================
  482.             IF (INDIC(JEL).NE.0) GOTO 1110            
  483.  
  484. *           2) OPTION 'FACE' (UNIQUEMENT POUR LES MAILLAGES DE SURFACES)
  485. *              =========================================================
  486.             IF (KFA.GT.0) THEN
  487.                IF (NBSOUS.NE.0) THEN
  488.                   IPT3=LISOUS(JON)
  489.                ELSE
  490.                   IPT3=MELEME
  491.                ENDIF
  492.  
  493. *              a) Verification que les elements ont au moins 1 autre 
  494. *                 noeud que IP en commun (attention : on ne verifie
  495. *                 pas qu'ils appartiennent a une meme arete)
  496.                DO 1150 I1=1,IPT1.NUM(/1)
  497.                   IP1=ICPR(IPT1.NUM(I1,IEL))
  498.                   IF (IP1.EQ.IP) GOTO 1150
  499.                   DO 1160 I2=1,IPT3.NUM(/1)
  500.                      IP2=ICPR(IPT3.NUM(I2,JEL))
  501.                      IF (IP1.EQ.IP2) GOTO 1170
  502. 1160              CONTINUE
  503. 1150           CONTINUE
  504.                GOTO 1110
  505.  
  506. *              b) Verification qu'il n'y a que 2 elements qui
  507. *                 contiennent les noeuds IP et IP1
  508. 1170           CONTINUE
  509.                NL=0
  510.                DO 1180 K1=JMEM(IP)+1,JMEM(IP+1)
  511.                   IF (K1.EQ.KK) GOTO 1180
  512.                   I1=LMEMO(K1)
  513.                   J1=IMEMO(K1)
  514.                   DO 1190 K2=JMEM(IP1)+1,JMEM(IP1+1)
  515.                      I2=LMEMO(K2)
  516.                      J2=IMEMO(K2)
  517.                      IF (I1.EQ.I2.AND.J1.EQ.J2) NL=NL+1
  518. 1190              CONTINUE
  519. 1180           CONTINUE
  520.                IF (NL.NE.1) GOTO 1110
  521.             ENDIF
  522.  
  523. *           3) OPTION 'LIGN' (UNIQUEMENT POUR LES MAILLAGES DE LIGNES)
  524. *              VERIFICATION QU'IL N'Y A QUE 2 ELEMENTS QUI CONTIENNENT
  525. *              LE NOEUD IP
  526. *              =======================================================
  527.             IF (KLI.GT.0) THEN
  528.                IF (JMEM(IP+1)-JMEM(IP).NE.2) GOTO 1110
  529.             ENDIF
  530.  
  531. *           4) OPTION 'ANGL' (POUR LES MAILLAGES DE LIGNES ET/OU DE
  532. *              SURFACE) : VERIFICATION QUE L'ANGLE ENTRE 2 ELEMENTS
  533. *              VOISINS EST INFERIEUR A UNE VALEUR SEUIL
  534. *              ====================================================
  535.             IF (KAN.GT.0) THEN
  536.  
  537. *              Vecteur directeur de l'element 2
  538. *              (vecteur directeur de l'element 1 sorti de la boucle)
  539.                MELVAL=IELVAX(JON)
  540.                JELMIN=MIN(JEL,MELVAL.VELCHE(/2))
  541.                X2=VELCHE(1,JELMIN)           
  542.                MELVAL=IELVAY(JON)
  543.                JELMIN=MIN(JEL,MELVAL.VELCHE(/2))
  544.                Y2=VELCHE(1,JELMIN)
  545.  
  546. *              Produit scalaire et norme
  547.                XN1=X1*X1+Y1*Y1
  548.                XN2=X2*X2+Y2*Y2
  549.                CA=X1*X2+Y1*Y2
  550.  
  551. *              Prise en compte 3eme direction le cas echeant
  552.                IF (IDIM.EQ.3) THEN                 
  553.                   MELVAL=IELVAZ(JON)
  554.                   JELMIN=MIN(JEL,MELVAL.VELCHE(/2))
  555.                   Z2=VELCHE(1,JELMIN)
  556.  
  557.                   XN1=XN1+Z1*Z1
  558.                   XN2=XN2+Z2*Z2
  559.                   CA=CA+Z1*Z2
  560.                ENDIF
  561.  
  562. *              Determination de l'angle en degres entre les 2 vecteurs
  563.                CA=CA/((XN1*XN2)**0.5)
  564.                IF (CA.GT.1.D0) CA=1.D0
  565.                IF (CA.LT.-1.D0) CA=-1.D0
  566.  
  567.                IF ((ITQ.GT.0.OR.(ITQ.LE.0.AND.CA.NE.-1.D0)).AND.
  568.      &             (CA.LT.ANG)) GOTO 1110
  569.             ENDIF
  570.  
  571. *           5) OPTION 'MAIL' : VERIFICATION QUE L'INTERFACE COMMUNE
  572. *              ENTRE 2 ELEMENTS VOISINS N'APPARTIENT PAS A MEL2
  573. *              ====================================================
  574.             IF (KMA.GT.0) THEN
  575.  
  576. *              Test rapide grace au noeud commun deja connu (IP et IPP
  577. *              sont les numeros locaux du meme noeud dans MEL1 et MEL2)
  578.                IPP=ICPR2(IPT1.NUM(IN,IEL))
  579.                IF (IPP.EQ.0) GOTO 999
  580.  
  581. *              Nb. de noeuds a l'interface entre ION/IEL et JON/JEL
  582. *              (IMPOSSIBLE A SAVOIR A PRIORI => EXEMPLE : CUB8/PY5)
  583.                IF (NBSOUS.NE.0) THEN
  584.                   IPT3=LISOUS(JON)
  585.                ELSE
  586.                   IPT3=MELEME
  587.                ENDIF
  588.                NBNIN=0
  589.                DO 1200 I1=1,IPT1.NUM(/1)
  590.                   IP1=ICPR(IPT1.NUM(I1,IEL))
  591.                   IF (IP1.EQ.IP) GOTO 1200
  592.                   DO I2=1,IPT3.NUM(/1)
  593.                      IP2=ICPR(IPT3.NUM(I2,JEL))
  594.                      IF (IP1.EQ.IP2) THEN
  595. *                       On a trouve un noeud de l'interface, mais s'il
  596. *                       n'est pas dans MEL2 => inutile d'aller plus loin
  597.                         IF (ICPR2(IPT3.NUM(I2,JEL)).EQ.0) GOTO 999
  598. *                       Sinon on le memorise et on en cherche d'autres
  599.                         NBNIN=NBNIN+1
  600.                         LISIN(NBNIN)=IPT3.NUM(I2,JEL)
  601.                         GOTO 1200
  602.                      ENDIF
  603.                   ENDDO
  604. 1200           CONTINUE
  605.  
  606. *              A ce stade, on connait tous les noeuds a l'interface
  607. *              entre les 2 elements voisins, et on sait qu'ils sont
  608. *              tous dans MEL2 => IL RESTE A VERIFIER QU'ILS SONT DANS 
  609. *              UN MEME ELEMENT DE MEL2 (la liste des possibilites
  610. *              est reduite grace aux tableaux JMEM2/IMEMO2/LMEMO2)
  611.                DO 1210 K2=JMEM2(IPP)+1,JMEM2(IPP+1)
  612.                   KON=LMEMO2(K2)
  613.                   KEL=IMEMO2(K2)
  614.                   IF (NBSOU2.NE.0) THEN
  615.                      IPT5=IPT2.LISOUS(KON)
  616.                   ELSE
  617.                      IPT5=IPT2
  618.                   ENDIF
  619.  
  620. *                 Inutile de tester cet element de MEL2 s'il n'a pas
  621. *                 assez de noeuds...
  622.                   IF (NBNNE(IPT5.ITYPEL).LT.NBNIN+1) GOTO 1210
  623.  
  624. *                 Test de tous les noeuds de l'interface
  625.                   DO 1220 K1=1,NBNIN
  626.                      INO=LISIN(K1)
  627.                      IF (ICPR2(INO).EQ.IPP) GOTO 1220
  628.                      DO K3=1,IPT5.NUM(/1)
  629.                         IF (INO.EQ.IPT5.NUM(K3,KEL)) GOTO 1220
  630.                      ENDDO
  631.                      GOTO 1210
  632. 1220              CONTINUE
  633.  
  634. *                 => L'INTERFACE ENTRE LES DEUX VOISINS EST INCLUSE
  635. *                    DANS UN ELEMENT DE MEL2
  636.                   GOTO 1110
  637.  
  638. 1210           CONTINUE
  639.  
  640.             ENDIF
  641.  
  642. *           => TOUS LES TESTS SONT PASSES : ON AJOUTE L'ELEMENT AUX
  643. *              LISTES LISCO1/LISCO2 ET ON LUI ATTRIBUE LA ZONE COURANTE
  644. 999         CONTINUE
  646.             ILRMP=ILRMP+1
  647.             LISCO1(ILRMP)=JON
  648.             LISCO2(ILRMP)=JEL
  649.  
  650. 1110     CONTINUE
  651. 1100  CONTINUE
  652.  
  653. *     Tous les voisins de l'element courant ont ete testes : on va
  654. *     regarder s'il reste des elements dans LISCO1/LISCO2
  655.       ILEXT=ILEXT+1
  656.       GOTO 1120
  657.  
  658. *     ON A FINI, ON ENCHAINE SUR LA ZONE SUIVANTE
  659. 1130  CONTINUE
  660.       GOTO 1000
  661.  
  662.  
  663. *     +---------------------------------------------------------------+
  664. *     |                                                               |
  665. *     |   C R E A T I O N   D E   L ' O B J E T   D E   S O R T I E   |
  666. *     |                                                               |
  667. *     +---------------------------------------------------------------+
  668.  
  669. 1500  CONTINUE
  670.       NBCOMP=NBCOMP-1
  671.  
  672. *     CREATION DE L'OBJET TABLE DE SORTIE
  673. *     ***********************************
  675.       IF (KESCL.GT.0) M=M+2
  676.       SEGINI,MTABLE
  677.       ITAB=MTABLE
  678.       IF (KESCL.GT.0) THEN
  679.          CALL ECCTAB(ITAB,'MOT',0,0.D0,'SOUSTYPE',.TRUE.,
  680.      &                     0,'MOT',0,0.D0,'ESCLAVE',.TRUE.,0)
  681.          CALL ECCTAB(ITAB,'MOT',0,0.D0,'CREATEUR',.TRUE.,
  682.      &                     0,'MOT',0,0.D0,'PART',.TRUE.,0)
  683.       ENDIF
  684.  
  685.  
  686. *     CREATION DES MAILLAGES DES DIFFERENTES ZONES TROUVEES
  687. *     *****************************************************
  688.       DO 2000 ICOMP=1,NBCOMP
  689.          ISS=0
  690.  
  691.          NBNN=0
  692.          NBELEM=0
  693.          NBSOUS=0
  694.          NBREF=0
  695.          SEGINI,IPT7
  696.  
  697. *        Boucle sur les LISOUS du maillage initial
  698.          DO 2010 IS=1,NBS
  699.             IF (LISOUS(/1).NE.0) IPT1=LISOUS(IS)
  700.             INDIC=LISIND(IS)
  701.  
  702. *           Decompte du nombre d'elements du LISOUS initial appartenant
  703. *           a la composante courante
  704.             IELEM=0
  705.             DO 2001 I=1,INDIC(/1)
  706.                IF (INDIC(I).EQ.ICOMP) IELEM=IELEM+1
  707. 2001        CONTINUE
  708.  
  709. *           Si besoin, on cree et on remplit le LISOUS correspondant
  710. *           dans IPT7
  711.             IF (IELEM.NE.0) THEN
  712.                ISS=ISS+1
  713.                NBNN=IPT1.NUM(/1)
  714.                NBELEM=IELEM
  715.                NBSOUS=0
  716.                NBREF=0
  717.                SEGINI,IPT3
  718.                IPT3.ITYPEL=IPT1.ITYPEL
  719.                IELEM=0
  720.                DO 2005 I=1,INDIC(/1)
  721.                   IF (INDIC(I).NE.ICOMP) GOTO 2005
  722.                   IELEM=IELEM+1
  723.                   DO 2006 J=1,IPT1.NUM(/1)
  724.                      IPT3.NUM(J,IELEM)=IPT1.NUM(J,I)
  725. 2006              CONTINUE
  726.                   IPT3.ICOLOR(IELEM)=IPT1.ICOLOR(I)
  727. 2005           CONTINUE
  728.                NBNN=0
  729.                NBELEM=0
  730.                NBSOUS=IPT7.LISOUS(/1)+1
  731.                NBREF=0
  732.                SEGADJ,IPT7
  733.                IPT7.LISOUS(NBSOUS)=IPT3
  734.                SEGDES,IPT3
  735.             ENDIF
  736. 2010     CONTINUE
  737. *
  738. *        S'il n'y a qu'un seul LISOUS, on modifie la structure de IPT7
  739.          IF (IPT7.LISOUS(/1).EQ.1) THEN
  740.             IPT=IPT7.LISOUS(1)
  741.             SEGSUP,IPT7
  742.             IPT7=IPT
  743.          ENDIF
  744.          SEGDES,IPT7
  745.  
  746. *        Ajout de IPT7 a l'indice ICOMP de MTABLE
  747.          CALL ECCTAB(MTABLE,'ENTIER  ',ICOMP,CC,' ',.TRUE.,I,
  748.      &                      'MAILLAGE',I,XX,' ',.TRUE.,IPT7)
  749. 2000  CONTINUE
  750.  
  751. *     FIN DE LA SUBROUTINE : UN PEU DE MENAGE...
  752. *     ******************************************
  753.       SEGSUP,JMEM,LMEMO,IMEMO,LISCO1,LISCO2
  754.       DO I=1,LISIND(/1)
  755.          INDIC=LISIND(I)
  756.          SEGSUP,INDIC
  757.       ENDDO
  758.       SEGSUP,LISIND
  759.       IF (KMA.NE.0) THEN
  760.          SEGSUP,ICPR2,JMEM2,LMEMO2,IMEMO2,LISIN
  761.          IF (NBSOU2.GT.0) THEN
  762.             DO I=1,IPT2.LISOUS(/1)
  763.                IPT5=IPT2.LISOUS(I)
  764.                SEGDES,IPT5
  765.             ENDDO
  766.          ENDIF
  767.          SEGDES,IPT2
  768.       ENDIF
  769. 9999  CONTINUE
  770.       SEGSUP,ICPR
  771.       NBSOUS=LISOUS(/1)
  772.       IF (NBSOUS.GT.0) THEN
  773.          DO I=1,NBSOUS
  774.             IPT1=LISOUS(I)
  775.             SEGDES,IPT1
  776.          ENDDO
  777.       ENDIF
  778.       SEGDES,MELEME
  779.       IF (KAN.GT.0) THEN
  780.          DO K=1,N1
  781.             MELVAL=IELVAX(K)
  782.             SEGSUP,MELVAL
  783.             MELVAL=IELVAY(K)
  784.             SEGSUP,MELVAL
  785.             IF (IDIM.EQ.3) THEN
  786.                MELVAL=IELVAZ(K)
  787.                SEGSUP,MELVAL
  788.             ENDIF
  789.          ENDDO
  790.          SEGSUP,MIELVA
  791.       ENDIF
  792.  
  793.       END
  794.  
  795.  
  796.  
  797.  
  798.  
  799.  
  800.  
  801.  
  802.  
  803.  
  804.  

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