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    GOUNAND   26/07/30    21:15:08     12610          
  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 CCREEL
  30. -INC CCGEOME
  31. -INC SMCOORD
  32. -INC SMELEME
  33. -INC SMTABLE
  34. -INC SMCHAML
  35. -INC SMMODEL
  36.  
  37.       SEGMENT JMEM(NODES+1)
  38. C     JMEM CONTIENT LE NOMBRE D'ELEMENTS AUQUEL APPARTIENT CHAQUE NOEUD
  39. C     PUIS LA POSITION DU PREMIER ELEMENT DANS IMEMO ET LMEMO
  40.  
  41.       SEGMENT ICPR(nbpts)
  42. C     ICPR(I) DONNE LE NUMERO LOCAL (DANS LES TABLEAUX DE LA PRESENTE
  43. C     SUBROUTINE) DU I-EME NOEUD GLOBAL (DANS LA TABLE MCOORD)
  44.  
  45.       SEGMENT IMEMO(NBV),LMEMO(NBV)
  46. C     CONTIENT LA LISTE DES ELEMENTS APPARTENANT AU NOEUD 1, 2, 3...
  47. C     (IMEMO => NUMERO DE L'ELEMENT ET LMEMO => NUMERO DU LISOUS)
  48.  
  49.       SEGMENT LISIND(NBS)
  50. C     POINTE VERS LES SEGMENTS INDIC ASSOCIES A CHAQUE SOUS-MAILLAGE
  51.  
  52.       SEGMENT JMEM2(NODES2+1),ICPR2(nbpts),IMEMO2(NBV2),
  53.      &        LMEMO2(NBV2)
  54. C     IDEM, MAIS POUR LE MAILLAGE SEPARATEUR
  55.  
  56.       SEGMENT INDIC(NBEL)
  57. C     INDICATEUR DU NUMERO DE ZONE
  58.  
  59.       SEGMENT LISCO1(NELTOT),LISCO2(NELTOT)
  60. C     LISTES DES ELEMENTS VOISINS
  61.  
  62.       SEGMENT LISIN(NNOMAX)
  63. C     LISTE DES NOEUDS A L'INTERFACE ENTRE DEUX ELEMENTS VOISINS
  64.  
  65.       SEGMENT MIELVA
  66.          INTEGER IELVAX(N1)
  67.          INTEGER IELVAY(N1)
  68.          INTEGER IELVAZ(N1)
  69.       ENDSEGMENT
  70. C     POINTEURS VERS LES SEGMENTS MELVAL (OPTION 'ANGL')
  71.  
  72.       LOGICAL KDIM1,KDIM2,KDIM3
  73.       INTEGER NNOMAX
  74.  
  75.  
  76.  
  77.  
  78. *     +---------------------------------------------------------------+
  79. *     |                                                               |
  80. *     |                 I N I T I A L I S A T I O N S                 |
  81. *     |                                                               |
  82. *     +---------------------------------------------------------------+
  83.  
  84.  
  85.  
  86. *     VERIFICATION QUE LE MAILLAGE EST COMPATIBLE AVEC LES OPTIONS
  87. *     FOURNIES
  88. *     ************************************************************
  89.       NNOMAX=0
  90.       MELEME=MEL1
  91.       SEGACT,MELEME
  92.       IPT1=MELEME
  93.       XTOL=XZPREC*10.D0
  94.  
  95.       IDIM1=0
  96.       IDIM2=0
  97.       IDIM3=0
  98.       DO ISO=1,MAX(1,LISOUS(/1))
  99.          IF (LISOUS(/1).GT.1) THEN
  100.             IPT1=LISOUS(ISO)
  101.             SEGACT,IPT1
  102.          ENDIF
  103.  
  104.          ITY=IPT1.ITYPEL
  105.          NNOMAX=MAX(NNOMAX,NBNNE(ITY))
  106.  
  107. *         KDIM1=(LDLR(ITY).EQ.1.AND.ITY.NE.12.AND.ITY.NE.13)
  108. *         KDIM2=(ITY.EQ.KSURF(ITY))
  109. *         KDIM3=(LDLR(ITY).EQ.3.AND.ITY.NE.30.AND.ITY.NE.31)
  110.          KDIM1=(LDLR(ITY).EQ.1)
  111.          KDIM2=(LDLR(ITY).EQ.2)
  112.          KDIM3=(LDLR(ITY).EQ.3)
  113.  
  114. *        Element special type 'MULT' ou 'SUPE'
  115.          IF (.NOT.(KDIM1.OR.KDIM2.OR.KDIM3)) THEN
  116.             CALL ERREUR(16)
  117.             RETURN
  118.          ENDIF
  119.  
  120.          IF (KDIM1) IDIM1=IDIM1+1
  121.          IF (KDIM2) IDIM2=IDIM2+1
  122.          IF (KDIM3) IDIM3=IDIM3+1
  123.       ENDDO
  124.  
  125.       IF ((KFA.GT.0.AND.(IDIM1.GT.0.OR.IDIM3.GT.0)).OR.
  126.      &    (KLI.GT.0.AND.(IDIM2.GT.0.OR.IDIM3.GT.0)).OR.
  127.      &    (KAN.GT.0.AND.IDIM3.GT.0)) THEN
  128.          CALL ERREUR(16)
  129.          RETURN
  130.       ENDIF
  131.  
  132.  
  133. *     OPTION 'ANGL' => CREATION DES TABLEAUX DONNANT LE VECTEUR
  134. *     NORMAL/TANGENT A CHAQUE ELEMENT
  135. *     *********************************************************
  136.  
  137.       IF (KAN.GT.0) THEN
  138. *        Creation d'un objet MMODEL temporaire (le type est sans
  139. *     importance)
  140.          CALL ECRCHA('BAR3')
  141.          CALL ECRCHA('POUT')
  142.          CALL ECRCHA('COQ8')
  143.          CALL ECRCHA('COQ6')
  144.          CALL ECRCHA('COQ4')
  145.          CALL ECRCHA('COQ3')
  146.          CALL ECRCHA('ELASTIQUE')
  147.          CALL ECRCHA('MECANIQUE')
  148.          CALL ECROBJ('MAILLAGE',MELEME)
  149.          CALL MODELI
  150.          IF (IERR.NE.0) RETURN
  151.          CALL LIROBJ('MMODEL  ',IPMODL,1,IRET)
  152.          CALL ACTOBJ('MMODEL  ',IPMODL,1)
  153.          IF (IERR.NE.0) RETURN
  154.  
  155. *        Calcul des vecteurs directeurs
  156.          SEGACT,MCOORD
  157.          CALL JACONO(IPMODL,1,IPCHE5,IRET)
  158.          IF (IERR.NE.0) RETURN
  159.  
  160. *        On ne garde qu'une seule valeur par element (=> type GRAVITE)
  161.          CALL CHASUP(IPMODL,IPCHE5,IPCHE2,IRET,2)
  162.          IF (IERR.NE.0) RETURN
  163.          IF (IRET.NE.0) THEN
  164.             CALL ERREUR(IRET)
  165.             RETURN
  166.          ENDIF
  167.  
  168. *        On recupere le MELEME pour etre sur d'avoir le bon ordre de
  169. *        description des elements
  170.          CALL ECRCHA('MAIL')
  171.          CALL ECROBJ('MCHAML',IPCHE2)
  172.          CALL EXTRAI
  173.          IF (IERR.NE.0) RETURN
  174.          CALL LIROBJ('MAILLAGE',MELEME,1,IRET)
  175.          IF (IERR.NE.0) RETURN
  176.  
  177. *        Suppression de l'objet MMODEL
  178.          MMODEL=IPMODL
  179.          SEGACT,MMODEL
  180.          DO K=1,KMODEL(/1)
  181.             IMODEL=KMODEL(K)
  182.             SEGSUP,IMODEL
  183.          ENDDO
  184.          SEGSUP,MMODEL
  185.  
  186. *        Remplissage du segment MIELVA (pointeurs vers les MELVAL)
  187.          MCHELM=IPCHE2
  188.          SEGACT,MCHELM
  189.          N1=ICHAML(/1)
  190.          SEGINI,MIELVA
  191.          DO I=1,N1
  192.             MCHAML=ICHAML(I)
  193.             SEGACT,MCHAML
  194.  
  195.             IELVAX(I)=IELVAL(1)
  196.             MELVAL=IELVAX(I)
  197.             SEGACT,MELVAL
  198.  
  199.             IELVAY(I)=IELVAL(2)
  200.             MELVAL=IELVAY(I)
  201.             SEGACT,MELVAL
  202.  
  203.             IF (IDIM.EQ.3) THEN
  204.                IELVAZ(I)=IELVAL(3)
  205.                MELVAL=IELVAZ(I)
  206.                SEGACT,MELVAL
  207.             ENDIF
  208.  
  209.             SEGSUP,MCHAML
  210.          ENDDO
  211.          SEGSUP,MCHELM
  212.  
  213.       ENDIF
  214.  
  215.  
  216. *     CORRESPONDANCE ENTRE LES NUMEROTATIONS LOCALE/GLOBALE
  217. *     *****************************************************
  218.  
  219.       SEGINI,ICPR
  220.  
  221.       SEGACT,MELEME
  222.       NBSOUS=LISOUS(/1)
  223.       NBS=MAX(1,NBSOUS)
  224.       IPT1=MELEME
  225.  
  226. *     Boucle sur les eventuels sous-maillages
  227.       IKOU=0
  228.       DO 100 IO=1,NBS
  229.          IF (NBSOUS.GT.0) THEN
  230.             IPT1=LISOUS(IO)
  231.             SEGACT,IPT1
  232.          ENDIF
  233.  
  234. *        Remplissage du tableau de correspondance ICPR
  235.          DO 150 J=1,IPT1.NUM(/2)
  236.             DO 151 I=1,IPT1.NUM(/1)
  237.                IJ=IPT1.NUM(I,J)
  238.                IF (ICPR(IJ).EQ.0) THEN
  239.                   IKOU=IKOU+1
  240.                   ICPR(IJ)=IKOU
  241.                ENDIF
  242.  151        CONTINUE
  243.  150     CONTINUE
  244.  
  245.  100  CONTINUE
  246.  
  247. *     Nombre de noeuds distincts dans le maillage
  248.       NODES=IKOU
  249.  
  250. *     MAILLAGE vide => on sort des maintenant
  251.       IF (NODES.EQ.0) THEN
  252.          M=0
  253.          SEGINI,MTABLE
  254.          ITAB=MTABLE
  255.          MLOTAB=0
  256.          GOTO 9999
  257.       ENDIF
  258.  
  259. *
  260. *     IDENTIFICATION DES ELEMENTS OU APPARAISSENT TOUS LES NOEUDS
  261. *          =>  IMEMO = NUMERO DE ELEMENT
  262. *          =>  LMEMO = NUMERO DU SOUS-MAILLGE
  263. *     JMEM(I)+1 IDENTIFIE LA POSITION DANS IMEMO/LMEMO DU PREMIER
  264. *     ELEMENT ASSOCIE AU NOEUD I
  265. *     ***************************************************************
  266.  
  267.       SEGINI,JMEM
  268.  
  269. *     On compte combien de fois chaque noeud apparait dans le maillage
  270.       DO 200 IO=1,NBS
  271.          IF (NBSOUS.GT.0) IPT1=LISOUS(IO)
  272.          DO 250 J=1,IPT1.NUM(/2)
  273.             DO 251 I=1,IPT1.NUM(/1)
  274.                IJ=ICPR(IPT1.NUM(I,J))
  275.                JMEM(IJ)=JMEM(IJ)+1
  276.  251        CONTINUE
  277.  250     CONTINUE
  278.  200  CONTINUE
  279. *
  280. *     On en deduit par cumul la position de depart dans IMEMO/LMEMO
  281.       DO 290 I=1+1,NODES+1
  282.          JMEM(I)=JMEM(I)+JMEM(I-1)
  283. 290   CONTINUE
  284.       NBV=JMEM(NODES)
  285. *
  286. *     Remplissage de IMEMO et LMEMO
  287.       SEGINI,IMEMO,LMEMO
  288.       DO 300 IO=1,NBS
  289.          IF (NBSOUS.GT.0) IPT1=LISOUS(IO)
  290.          DO 350 J=1,IPT1.NUM(/2)
  291.             DO 351 I=1,IPT1.NUM(/1)
  292.                IJ=ICPR(IPT1.NUM(I,J))
  293.                IMEMO(JMEM(IJ))=J
  294.                LMEMO(JMEM(IJ))=IO
  295.                JMEM(IJ)=JMEM(IJ)-1
  296.  351        CONTINUE
  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 402 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.  402           CONTINUE
  328.  401        CONTINUE
  329.  400     CONTINUE
  330.          NODES2=IKOU
  331.  
  332. *        MAILLAGE vide => l'option 'MAIL' est desactivee
  333.          IF (NODES2.EQ.0) THEN
  334.             DO 410 IO=1,NBS2
  335.                IF (NBSOU2.GT.0) IPT5=IPT2.LISOUS(IO)
  336.                SEGDES,IPT5
  337. 410         CONTINUE
  338.             SEGSUP,ICPR2
  339.             KMA=0
  340.             GOTO 499
  341.          ENDIF
  342.  
  343. *        Tableaux JMEM2, IMEMO2 et LMEMO2
  344.          SEGINI,JMEM2
  345.          DO 420 IO=1,NBS2
  346.             IF (NBSOU2.GT.0) IPT5=IPT2.LISOUS(IO)
  347.             DO 421 J=1,IPT5.NUM(/2)
  348.                DO 422 I=1,IPT5.NUM(/1)
  349.                   IJ=ICPR2(IPT5.NUM(I,J))
  350.                   JMEM2(IJ)=JMEM2(IJ)+1
  351.  422           CONTINUE
  352.  421        CONTINUE
  353.  420     CONTINUE
  354.          DO 430 I=1+1,NODES2+1
  355.             JMEM2(I)=JMEM2(I)+JMEM2(I-1)
  356.  430     CONTINUE
  357.          NBV2=JMEM2(NODES2)
  358.          SEGINI,IMEMO2,LMEMO2
  359.          DO 440 IO=1,NBS2
  360.             IF (NBSOU2.GT.0) IPT5=IPT2.LISOUS(IO)
  361.             DO 441 J=1,IPT5.NUM(/2)
  362.                DO 442 I=1,IPT5.NUM(/1)
  363.                   IJ=ICPR2(IPT5.NUM(I,J))
  364.                   IMEMO2(JMEM2(IJ))=J
  365.                   LMEMO2(JMEM2(IJ))=IO
  366.                   JMEM2(IJ)=JMEM2(IJ)-1
  367.  442           CONTINUE
  368.  441        CONTINUE
  369.  440     CONTINUE
  370.  
  371. *        On cree aussi le segment LISIN qui servira plus bas
  372.          SEGINI,LISIN
  373.  
  374.       ENDIF
  375. 499   CONTINUE
  376.  
  377.  
  378. *     CREATION D'UN SEGMENT INDIC POUR CHAQUE LISOUS
  379. *     **********************************************
  380.  
  381.       SEGINI,LISIND
  382.       NELTOT=0
  383.       DO 500 IO=1,NBS
  384.          IF (NBSOUS.NE.0) IPT1=LISOUS(IO)
  385.          NBEL=IPT1.NUM(/2)
  386.          NELTOT=NELTOT+NBEL
  387.          SEGINI,INDIC
  388.          LISIND(IO)=INDIC
  389.  500  CONTINUE
  390.       SEGINI LISCO1,LISCO2
  391.  
  392.  
  393.  
  394. *     +---------------------------------------------------------------+
  395. *     |                                                               |
  396. *     |          C O N S T R U C T I O N   D E S   Z O N E S          |
  397. *     |                                                               |
  398. *     +---------------------------------------------------------------+
  399.  
  401.       IOC=1
  402.       IELC=0
  403.  
  404. *     LABEL 1000 : PARCOURS DES SEGMENTS INDIC A LA RECHERCHE D'UN
  405. *                  ELEMENT ENCORE NON ATTRIBUE
  406. *     ************************************************************
  407. 1000  CONTINUE
  408.  
  410.       IELC=IELC+1
  411.       DO 1010 IO=IOC,NBS
  412.          IF (NBSOUS.NE.0) IPT1=LISOUS(IO)
  413.          INDIC=LISIND(IO)
  414.          DO 1020 IEL=IELC,IPT1.NUM(/2)
  415.             IF (INDIC(IEL).EQ.0) GOTO 1030
  416. 1020     CONTINUE
  417.          IELC=1
  418. 1010  CONTINUE
  419.  
  420. C     TOUS LES ELEMENTS ONT ETE CLASSES => ON A FINI
  421.       GOTO 1500
  422.  
  423. *     ON A TROUVE UN ELEMENT DE DEPART D'UNE NOUVELLE ZONE
  424. *     => ON VA ETENDRE AUX ELEMENTS VOISINS
  425. *     ****************************************************
  426. 1030  CONTINUE
  427.       IOC=IO
  428.       IELC=IEL
  429.  
  430. *     On attribue une zone a l'element trouve
  432.  
  433. *     ILRMP = Nombre d'elements ajoutes a LISCO1/LISCO2
  434. *     ILEXT = Nombre d'elements parcourus dans LISCO1/LISCO2
  435.       ILRMP=1
  436.       ILEXT=1
  437.  
  438. *     On reinitialise LISCO1/LISCO2 avec seulement cet element
  439.       LISCO1(ILRMP)=IO
  440.       LISCO2(ILRMP)=IEL
  441.  
  442. *     BOUCLE DE REMPLISSAGE DE LISCO1/LISCO2, DE VOISIN EN VOISIN
  443. *     ***********************************************************
  444.  
  445. *     Label 1120 => element suivant dans les listes LISCO1/LISCO2
  446. 1120  CONTINUE
  447.       IF (ILEXT.GT.ILRMP) GOTO 1130
  448.  
  449.       ION=LISCO1(ILEXT)
  450.       IEL=LISCO2(ILEXT)
  451.       IF (NBSOUS.NE.0) IPT1=LISOUS(ION)
  452.       IF (KAN.GT.0) THEN
  453. *        Vecteur directeur de l'element 1 (option 'ANGL')
  454.          MELVAL=IELVAX(ION)
  455.          IELMIN=MIN(IEL,MELVAL.VELCHE(/2))
  456.          X1=VELCHE(1,IELMIN)
  457.          MELVAL=IELVAY(ION)
  458.          IELMIN=MIN(IEL,MELVAL.VELCHE(/2))
  459.          Y1=VELCHE(1,IELMIN)
  460.          IF (IDIM.EQ.3) THEN
  461.             MELVAL=IELVAZ(ION)
  462.             IELMIN=MIN(IEL,MELVAL.VELCHE(/2))
  463.             Z1=VELCHE(1,IELMIN)
  464.          ENDIF
  465.       ENDIF
  466.  
  467. *     Label 1100 => noeud IP suivant de l'element courant
  468.       DO 1100 IN=1,IPT1.NUM(/1)
  469.          IP=ICPR(IPT1.NUM(IN,IEL))
  470.  
  471. *        Label 1110 => voisin suivant via le noeud IP
  472.          DO 1110 KK=JMEM(IP)+1,JMEM(IP+1)
  473.             JON=LMEMO(KK)
  474.             JEL=IMEMO(KK)
  475.             INDIC=LISIND(JON)
  476.  
  477.  
  478. *           TESTS SUR L'ELEMENT VOISIN (JON;JEL) : SI L'UN DES TESTS
  479. *           ECHOUE, ALORS CET ELEMENT N'APPARTIENT PAS A CETTE ZONE
  480. *           ********************************************************
  481.  
  482. *           1) CONDITION SINE QUA NONE : IL N'A PAS DEJA ETE ATTRIBUE
  483. *              A UNE AUTRE ZONE
  484. *              ======================================================
  485.             IF (INDIC(JEL).NE.0) GOTO 1110
  486.  
  487. *           2) OPTION 'FACE' (UNIQUEMENT POUR LES MAILLAGES DE SURFACES)
  488. *              =========================================================
  489.             IF (KFA.GT.0) THEN
  490.                IF (NBSOUS.NE.0) THEN
  491.                   IPT3=LISOUS(JON)
  492.                ELSE
  493.                   IPT3=MELEME
  494.                ENDIF
  495.  
  496. *              a) Verification que les elements ont au moins 1 autre
  497. *                 noeud que IP en commun (attention : on ne verifie
  498. *                 pas qu'ils appartiennent a une meme arete)
  499.                DO 1150 I1=1,IPT1.NUM(/1)
  500.                   IP1=ICPR(IPT1.NUM(I1,IEL))
  501.                   IF (IP1.EQ.IP) GOTO 1150
  502.                   DO 1160 I2=1,IPT3.NUM(/1)
  503.                      IP2=ICPR(IPT3.NUM(I2,JEL))
  504.                      IF (IP1.EQ.IP2) GOTO 1170
  505. 1160              CONTINUE
  506. 1150           CONTINUE
  507.                GOTO 1110
  508.  
  509. *              b) Verification qu'il n'y a que 2 elements qui
  510. *                 contiennent les noeuds IP et IP1
  511. 1170           CONTINUE
  512.                NL=0
  513.                DO 1180 K1=JMEM(IP)+1,JMEM(IP+1)
  514.                   IF (K1.EQ.KK) GOTO 1180
  515.                   I1=LMEMO(K1)
  516.                   J1=IMEMO(K1)
  517.                   DO 1190 K2=JMEM(IP1)+1,JMEM(IP1+1)
  518.                      I2=LMEMO(K2)
  519.                      J2=IMEMO(K2)
  520.                      IF (I1.EQ.I2.AND.J1.EQ.J2) NL=NL+1
  521. 1190              CONTINUE
  522. 1180           CONTINUE
  523.                IF (NL.NE.1) GOTO 1110
  524.             ENDIF
  525.  
  526. *           3) OPTION 'LIGN' (UNIQUEMENT POUR LES MAILLAGES DE LIGNES)
  527. *              VERIFICATION QU'IL N'Y A QUE 2 ELEMENTS QUI CONTIENNENT
  528. *              LE NOEUD IP
  529. *              =======================================================
  530.             IF (KLI.GT.0) THEN
  531.                IF (JMEM(IP+1)-JMEM(IP).NE.2) GOTO 1110
  532.             ENDIF
  533.  
  534. *           4) OPTION 'ANGL' (POUR LES MAILLAGES DE LIGNES ET/OU DE
  535. *              SURFACE) : VERIFICATION QUE L'ANGLE ENTRE 2 ELEMENTS
  536. *              VOISINS EST INFERIEUR A UNE VALEUR SEUIL
  537. *              ====================================================
  538.             IF (KAN.GT.0) THEN
  539.  
  540. *              Vecteur directeur de l'element 2
  541. *              (vecteur directeur de l'element 1 sorti de la boucle)
  542.                MELVAL=IELVAX(JON)
  543.                JELMIN=MIN(JEL,MELVAL.VELCHE(/2))
  544.                X2=VELCHE(1,JELMIN)
  545.                MELVAL=IELVAY(JON)
  546.                JELMIN=MIN(JEL,MELVAL.VELCHE(/2))
  547.                Y2=VELCHE(1,JELMIN)
  548.  
  549. *              Produit scalaire et norme
  550.                XN1=X1*X1+Y1*Y1
  551.                XN2=X2*X2+Y2*Y2
  552.                CA=X1*X2+Y1*Y2
  553.  
  554. *              Prise en compte 3eme direction le cas echeant
  555.                IF (IDIM.EQ.3) THEN
  556.                   MELVAL=IELVAZ(JON)
  557.                   JELMIN=MIN(JEL,MELVAL.VELCHE(/2))
  558.                   Z2=VELCHE(1,JELMIN)
  559.  
  560.                   XN1=XN1+Z1*Z1
  561.                   XN2=XN2+Z2*Z2
  562.                   CA=CA+Z1*Z2
  563.                ENDIF
  564.  
  565. *              Determination de l'angle en degres entre les 2 vecteurs
  566.                CA=CA/((XN1*XN2)**0.5)
  567.                IF ((ITQ.GT.0.OR.(ITQ.LE.0.AND.(ABS(CA+1.D0).GT.XTOL)))
  568.      $              .AND.(CA.LE.ANG+XTOL)) 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.  

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