Télécharger part7.eso

Retour à la liste

Numérotation des lignes :

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

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