Télécharger part7.eso

Retour à la liste

Numérotation des lignes :

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

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