Télécharger part7.eso

Retour à la liste

Numérotation des lignes :

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

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