Télécharger part7.eso

Retour à la liste

Numérotation des lignes :

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

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