Télécharger part7.eso

Retour à la liste

Numérotation des lignes :

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

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