Télécharger coupe.eso

Retour à la liste

Numérotation des lignes :

  1. C COUPE SOURCE BP208322 16/11/18 21:15:55 9177
  2. SUBROUTINE COUPE
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. -INC CCOPTIO
  6. -INC SMELEME
  7. -INC CCGEOME
  8. -INC SMCOORD
  9. -INC SMLENTI
  10. -INC SMLREEL
  11. C
  12. DIMENSION XYZT(3),XYZ2(3),XYZ3(3),XYZN(3)
  13. DIMENSION XYZ(4,4),DIS(4)
  14. C
  15. EQUIVALENCE(XYZT(1),XCT),(XYZT(2),YCT),(XYZT(3),ZCT)
  16. EQUIVALENCE(XYZ2(1),XC2),(XYZ2(2),YC2),(XYZ2(3),ZC2)
  17. EQUIVALENCE(XYZ3(1),XC3),(XYZ3(2),YC3),(XYZ3(3),ZC3)
  18. EQUIVALENCE(XYZN(1),XN) ,(XYZN(2),YN) ,(XYZN(3),ZN)
  19. C
  20. EQUIVALENCE(XYZ(1,1),XCA),(XYZ(2,1),YCA),(XYZ(3,1),ZCA)
  21. EQUIVALENCE(XYZ(1,2),XCB),(XYZ(2,2),YCB),(XYZ(3,2),ZCB)
  22. EQUIVALENCE(XYZ(1,3),XCC),(XYZ(2,3),YCC),(XYZ(3,3),ZCC)
  23. EQUIVALENCE(XYZ(1,4),XCD),(XYZ(2,4),YCD),(XYZ(3,4),ZCD)
  24. EQUIVALENCE(DIS(1),DI1),(DIS(2),DI2),(DIS(3),DI3),(DIS(4),DI4)
  25. C
  26. PARAMETER(UN=1.D0,DEUX=2.D0,ZERO=0.D0)
  27. C
  28. C LECTURE DES DONNEES
  29. C
  30. IF (IDIM.NE.3) THEN
  31. WRITE(IOIMP,*)'COUPE: You must be in 3D'
  32. CALL ERREUR(0)
  33. RETURN
  34. ENDIF
  35. C
  36. CALL LIROBJ('POINT',ICOUP1,1,IRETOU)
  37. IF (IRETOU.EQ.0) RETURN
  38. CALL LIROBJ('POINT',ICOUP2,1,IRETOU)
  39. IF (IRETOU.EQ.0) RETURN
  40. CALL LIROBJ('POINT',ICOUP3,1,IRETOU)
  41. IF (IRETOU.EQ.0) RETURN
  42. CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  43. IF (IRETOU.EQ.0) RETURN
  44. C
  45. C CARACTERISTIQUE DU PLAN DE COUPE
  46. C
  47. IREF=(ICOUP1-1)*4
  48. XCT=XCOOR(IREF+1)
  49. YCT=XCOOR(IREF+2)
  50. ZCT=XCOOR(IREF+3)
  51. C
  52. IREF=(ICOUP2-1)*4
  53. XC2=XCOOR(IREF+1)
  54. YC2=XCOOR(IREF+2)
  55. ZC2=XCOOR(IREF+3)
  56. C
  57. IREF=(ICOUP3-1)*4
  58. XC3=XCOOR(IREF+1)
  59. YC3=XCOOR(IREF+2)
  60. ZC3=XCOOR(IREF+3)
  61. C
  62. TOL1=MIN(SQRT((XC2-XCT)**2+(YC2-YCT)**2+(ZC2-ZCT)**2),
  63. > SQRT((XC3-XCT)**2+(YC3-YCT)**2+(ZC3-ZCT)**2))/10
  64. TOL4=TOL1/1000
  65. C :
  66. XV=XC2-XCT
  67. YV=YC2-YCT
  68. ZV=ZC2-ZCT
  69. XW=XC3-XCT
  70. YW=YC3-YCT
  71. ZW=ZC3-ZCT
  72. XN=YV*ZW-ZV*YW
  73. YN=ZV*XW-XV*ZW
  74. ZN=XV*YW-YV*XW
  75. RN=XN**2+YN**2+ZN**2
  76. IF (RN.EQ.0.) CALL ERREUR(21)
  77. IF (IERR.NE.0) RETURN
  78. RN=SQRT(RN)
  79. XN=XN/RN
  80. YN=YN/RN
  81. ZN=ZN/RN
  82. C
  83. C PREPARATION DU MAILLAGE
  84. C
  85. SEGACT,IPT1
  86. MBSOUS=IPT1.LISOUS(/1)
  87. IF(MBSOUS.EQ.0)THEN
  88. NBSOUS=1
  89. NBREF=0
  90. NBNN=0
  91. NBELEM=0
  92. SEGINI,IPT2
  93. IPT2.LISOUS(1)=IPT1
  94. ELSE
  95. SEGINI,IPT2=IPT1
  96. ENDIF
  97. SEGDES,IPT1
  98. C
  99. C BOUCLE SUR LES ZONES DU MAILLAGE
  100. C
  101. MBSOUS=IPT2.LISOUS(/1)
  102. DO IE1=1,MBSOUS
  103. C
  104. C -> REDUCTION DES MAILLAGES A 3 TYPES D'ELEMENTS
  105. C
  106. IPT1=IPT2.LISOUS(IE1)
  107. SEGACT,IPT1
  108. ITYP=IPT1.ITYPEL
  109. ITYQ=0
  110. C CAS DES SEG3 QUE L'ON TRANFORME EN SEG2
  111. IF(ITYP.EQ.3)THEN
  112. ITYQ=2
  113. CALL CHANGE(IPT1,ITYQ)
  114. C CAS DE TRI6, QUA4 ET QUA8 QUE L'ON TRANFORME EN TRI3
  115. ELSE IF(ITYP.EQ.6.OR.ITYP.EQ.8.OR.ITYP.EQ.10)THEN
  116. ITYQ=4
  117. CALL CHANGE(IPT1,ITYQ)
  118. C CAS DE CUB8, CU20, PRI6, PR15,
  119. C TE10, PYR5, PY13 QUE L'ON TRANFORME EN TRI3
  120. C IF(ITYP.EQ.14.OR.ITYP.EQ.15.OR.ITYP.EQ.16.OR.ITYP.EQ.17
  121. C > .OR.ITYP.EQ.24.OR.ITYP.EQ.25.OR.ITYP.EQ.26)THEN
  122. C CAS DE TE10 QUE L'ON TRANFORME EN TET4
  123. ELSE IF (ITYP.EQ.24)THEN
  124. ITYQ=23
  125. CALL CHANGE(IPT1,ITYQ)
  126. ENDIF
  127. ITYP=IPT1.ITYPEL
  128. NBELEM=IPT1.NUM(/2)
  129. MBELEM=NBELEM
  130. NBREF=0
  131. NBSOUS=0
  132. C
  133. C -> AIGUILLAGE SUR LES TYPES D'ELEMENTS
  134. C
  135. IF(ITYP.EQ.2)THEN
  136. C
  137. C --> TRAVAIL SUR LES SEG2 (--> SEG2 OR POI1)
  138. C
  139. NBNN=1
  140. SEGINI,MELEME
  141. ITYPEL=1
  142. C
  143. NBNN=2
  144. SEGINI,IPT3
  145. IPT3.ITYPEL=2
  146. C
  147. NBELEM=0
  148. NBELE3=0
  149. C
  150. DO IE2=1,MBELEM
  151. JCOLOR=IPT1.ICOLOR(IE2)
  152. DO IE3=1,2
  153. IREF=(IPT1.NUM(IE3,IE2)-1)*4
  154. DO IE4=1,3+1
  155. XYZ(IE4,IE3)=XCOOR(IREF+IE4)
  156. ENDDO
  157. CALL COUPEC(XYZ(1,IE3),XYZT,XYZ2,XYZ3,XYZN,TOL1, DIS(IE3))
  158. ENDDO
  159. C COTE DANS LE PLAN DE COUPE
  160. IF (ABS(DI1)+ABS(DI2).LT.TOL4)THEN
  161. NBELE3=NBELE3+1
  162. IPT3.NUM(1,NBELE3)=IPT1.NUM(1,IE2)
  163. IPT3.NUM(2,NBELE3)=IPT1.NUM(2,IE2)
  164. IPT3.ICOLOR(NBELE3)=JCOLOR
  165. C
  166. ELSEIF(SIGN(UN,DI1)+SIGN(UN,DI2).EQ.ZERO .OR.
  167. > ABS(DI1).LT.TOL4 .OR. ABS(DI2).LT.TOL4)THEN
  168. C INTERSECTION OU POINT DANS LE PLAN DE COUPE
  169. NBPTI=XCOOR(/1)/4
  170. NBPTS=NBPTI+1
  171. SEGADJ,MCOORD
  172. C
  173. COEFF=ABS(DI1)/(ABS(DI1)+ABS(DI2))
  174. NBPTI=NBPTI+1
  175. IREF=(NBPTI-1)*4
  176. DO IE3=1,4
  177. XCOOR(IREF+IE3)=XYZ(1,IE3)+COEFF*(XYZ(2,IE3)-XYZ(1,IE3))
  178. ENDDO
  179. C
  180. NBELEM=NBELEM+1
  181. NUM(1,NBELEM)=NBPTI
  182. ICOLOR(NBELEM)=JCOLOR
  183. ENDIF
  184. ENDDO
  185. C STOCKAGE EVENTUEL DU MAILLAGE SUPLEMENTAIRE
  186. IF(NBELEM.EQ.0)THEN
  187. SEGSUP,MELEME
  188. NBELEM=NBELE3
  189. MELEME=IPT3
  190. SEGADJ,MELEME
  191. ELSE
  192. NBNN=1
  193. SEGADJ,MELEME
  194. NBELEM=NBELE3
  195. NBNN=2
  196. SEGADJ,IPT3
  197. C
  198. NBELEM=0
  199. NBNN=0
  200. NBSOUS=IPT2.LISOUS(/1)+1
  201. SEGADJ,IPT2
  202. IPT2.LISOUS(NBSOUS)=IPT3
  203. ENDIF
  204. ELSE IF(ITYP.EQ.4)THEN
  205. C
  206. C --> TRAVAIL SUR LES TRI3 (--> TRI3 OR SEG2)
  207. C
  208. NBNN=2
  209. SEGINI,MELEME
  210. ITYPEL=2
  211. NBELEM=0
  212. DO IE2=1,MBELEM
  213. C A FAIRE......
  214. ENDDO
  215. SEGADJ,MELEME
  216. ELSE IF(ITYP.EQ.23)THEN
  217. C
  218. C --> TRAVAIL SUR LES TET4 (--> TRI3)
  219. C
  220. NBELEM=NBELEM*2
  221. NBNN=3
  222. SEGINI,MELEME
  223. ITYPEL=4
  224. NBELEM=0
  225. C
  226. DO IE2=1,MBELEM
  227. JCOLOR=IPT1.ICOLOR(IE2)
  228. DO IE3=1,4
  229. IREF=(IPT1.NUM(IE3,IE2)-1)*4
  230. DO IE4=1,3+1
  231. XYZ(IE4,IE3)=XCOOR(IREF+IE4)
  232. ENDDO
  233. CALL COUPEC(XYZ(1,IE3),XYZT,XYZ2,XYZ3,XYZN,TOL1, DIS(IE3))
  234. ENDDO
  235. C
  236. IF (ABS(DIS(1))+ABS(DIS(2))+ABS(DIS(3)).LT.TOL4)THEN
  237. C FACE 1 DS LE PLAN DE COUPE
  238. NBELEM=NBELEM+1
  239. NUM(1,NBELEM)=IPT1.NUM(1,IE2)
  240. NUM(2,NBELEM)=IPT1.NUM(2,IE2)
  241. NUM(3,NBELEM)=IPT1.NUM(3,IE2)
  242. ICOLOR(NBELEM)=JCOLOR
  243. ELSEIF(ABS(DIS(1))+ABS(DIS(2))+ABS(DIS(4)).LT.TOL4)THEN
  244. C FACE 2 DS LE PLAN DE COUPE
  245. NBELEM=NBELEM+1
  246. NUM(1,NBELEM)=IPT1.NUM(1,IE2)
  247. NUM(2,NBELEM)=IPT1.NUM(2,IE2)
  248. NUM(3,NBELEM)=IPT1.NUM(4,IE2)
  249. ICOLOR(NBELEM)=JCOLOR
  250. ELSEIF(ABS(DIS(1))+ABS(DIS(3))+ABS(DIS(4)).LT.TOL4)THEN
  251. C FACE 3 DS LE PLAN DE COUPE
  252. NBELEM=NBELEM+1
  253. NUM(1,NBELEM)=IPT1.NUM(1,IE2)
  254. NUM(2,NBELEM)=IPT1.NUM(3,IE2)
  255. NUM(3,NBELEM)=IPT1.NUM(4,IE2)
  256. ICOLOR(NBELEM)=JCOLOR
  257. ELSEIF(ABS(DIS(2))+ABS(DIS(3))+ABS(DIS(4)).LT.TOL4)THEN
  258. C FACE 4 DS LE PLAN DE COUPE
  259. NBELEM=NBELEM+1
  260. NUM(1,NBELEM)=IPT1.NUM(2,IE2)
  261. NUM(2,NBELEM)=IPT1.NUM(3,IE2)
  262. NUM(3,NBELEM)=IPT1.NUM(4,IE2)
  263. ICOLOR(NBELEM)=JCOLOR
  264. ELSEIF(ABS(DI1)+ABS(DI2).LT.TOL4)THEN
  265. C COTE 12 DS LE PLAN DE COUPE
  266. DINDEX=SIGN(UN,DI3)+SIGN(UN,DI4)
  267. IF(DINDEX.EQ.0)THEN
  268. NUMA=IPT1.NUM(1,IE2)
  269. NUMB=IPT1.NUM(2,IE2)
  270. CALL COUPEM(XYZ(1,3),XYZ(1,4),DI3,DI4,
  271. > NUMA,NUMB,MELEME,NBELEM,JCOLOR)
  272. ENDIF
  273. ELSEIF(ABS(DI1)+ABS(DI3).LT.TOL4)THEN
  274. C COTE 13 DS LE PLAN DE COUPE
  275. DINDEX=SIGN(UN,DI2)+SIGN(UN,DI4)
  276. IF(DINDEX.EQ.0)THEN
  277. NUMA=IPT1.NUM(1,IE2)
  278. NUMB=IPT1.NUM(3,IE2)
  279. CALL COUPEM(XYZ(1,2),XYZ(1,4),DI2,DI4,
  280. > NUMA,NUMB,MELEME,NBELEM,JCOLOR)
  281. ENDIF
  282. ELSEIF(ABS(DI1)+ABS(DI4).LT.TOL4)THEN
  283. C COTE 14 DS LE PLAN DE COUPE
  284. DINDEX=SIGN(UN,DI2)+SIGN(UN,DI3)
  285. IF(DINDEX.EQ.0)THEN
  286. NUMA=IPT1.NUM(1,IE2)
  287. NUMB=IPT1.NUM(4,IE2)
  288. CALL COUPEM(XYZ(1,2),XYZ(1,3),DI2,DI3,
  289. > NUMA,NUMB,MELEME,NBELEM,JCOLOR)
  290. ENDIF
  291. ELSEIF(ABS(DI2)+ABS(DI3).LT.TOL4)THEN
  292. C COTE 23 DS LE PLAN DE COUPE
  293. DINDEX=SIGN(UN,DI1)+SIGN(UN,DI4)
  294. IF(DINDEX.EQ.0)THEN
  295. NUMA=IPT1.NUM(2,IE2)
  296. NUMB=IPT1.NUM(3,IE2)
  297. CALL COUPEM(XYZ(1,1),XYZ(1,4),DI1,DI4,
  298. > NUMA,NUMB,MELEME,NBELEM,JCOLOR)
  299. ENDIF
  300. ELSEIF(ABS(DI2)+ABS(DI4).LT.TOL4)THEN
  301. C COTE 24 DS LE PLAN DE COUPE
  302. DINDEX=SIGN(UN,DI1)+SIGN(UN,DI3)
  303. IF(DINDEX.EQ.0)THEN
  304. NUMA=IPT1.NUM(2,IE2)
  305. NUMB=IPT1.NUM(4,IE2)
  306. CALL COUPEM(XYZ(1,1),XYZ(1,3),DI1,DI3,
  307. > NUMA,NUMB,MELEME,NBELEM,JCOLOR)
  308. ENDIF
  309. ELSEIF(ABS(DI3)+ABS(DI4).LT.TOL4)THEN
  310. C COTE 34 DS LE PLAN DE COUPE
  311. DINDEX=SIGN(UN,DI1)+SIGN(UN,DI2)
  312. IF(DINDEX.EQ.0)THEN
  313. NUMA=IPT1.NUM(3,IE2)
  314. NUMB=IPT1.NUM(4,IE2)
  315. CALL COUPEM(XYZ(1,1),XYZ(1,2),DI1,DI2,
  316. > NUMA,NUMB,MELEME,NBELEM,JCOLOR)
  317. ENDIF
  318. ELSEIF(ABS(DI1).LT.TOL4)THEN
  319. C POINT 1 DANS LE PLAN DE COUPE
  320. DINDEX=SIGN(UN,DI2)+SIGN(UN,DI3)+SIGN(UN,DI4)
  321. IF(ABS(DINDEX).EQ.UN)THEN
  322. NUM0=IPT1.NUM(1,IE2)
  323. CALL COUPEK(XYZ(1,2),XYZ(1,3),XYZ(1,4),
  324. > DI2 , DI3 , DI4,
  325. > NUM0,MELEME,NBELEM,JCOLOR)
  326. ENDIF
  327. ELSE IF(ABS(DI2).LT.TOL4)THEN
  328. C POINT 2 DANS LE PLAN DE COUPE
  329. DINDEX=SIGN(UN,DI3)+SIGN(UN,DI4)+SIGN(UN,DI1)
  330. IF(ABS(DINDEX).EQ.UN)THEN
  331. NUM0=IPT1.NUM(2,IE2)
  332. CALL COUPEK(XYZ(1,3),XYZ(1,4),XYZ(1,1),
  333. > DI3 , DI4 , DI1,
  334. > NUM0,MELEME,NBELEM,JCOLOR)
  335. ENDIF
  336. ELSE IF(ABS(DI3).LT.TOL4)THEN
  337. C POINT 3 DANS LE PLAN DE COUPE
  338. DINDEX=SIGN(UN,DI4)+SIGN(UN,DI1)+SIGN(UN,DI2)
  339. IF(ABS(DINDEX).EQ.UN)THEN
  340. NUM0=IPT1.NUM(3,IE2)
  341. CALL COUPEK(XYZ(1,4),XYZ(1,1),XYZ(1,2),
  342. > DI4 , DI1 , DI2,
  343. > NUM0,MELEME,NBELEM,JCOLOR)
  344. ENDIF
  345. ELSE IF(ABS(DI4).LT.TOL4)THEN
  346. C POINT 4 DANS LE PLAN DE COUPE
  347. DINDEX=SIGN(UN,DI1)+SIGN(UN,DI2)+SIGN(UN,DI3)
  348. IF(ABS(DINDEX).EQ.UN)THEN
  349. NUM0=IPT1.NUM(4,IE2)
  350. CALL COUPEK(XYZ(1,1),XYZ(1,2),XYZ(1,3),
  351. > DI1 , DI2 , DI3,
  352. > NUM0,MELEME,NBELEM,JCOLOR)
  353. ENDIF
  354. ELSE
  355. DINDEX=SIGN(UN,DI1)+SIGN(UN,DI2)+SIGN(UN,DI3)+SIGN(UN,DI4)
  356. IF(ABS(DINDEX).EQ.DEUX)THEN
  357. C INTERSECTION PAR UNE POINTE
  358. IF(SIGN(UN,DI1).NE.SIGN(UN,DINDEX))THEN
  359. C POINTE N.1
  360. CALL COUPEI(XYZ(1,1),XYZ(1,2),XYZ(1,3),XYZ(1,4),
  361. > DI1 , DI2 , DI3 , DI4,
  362. > MELEME,NBELEM,JCOLOR)
  363. ELSE IF(SIGN(UN,DI2).NE.SIGN(UN,DINDEX))THEN
  364. C POINTE N.2
  365. CALL COUPEI(XYZ(1,2),XYZ(1,3),XYZ(1,4),XYZ(1,1),
  366. > DI2 , DI3 , DI4 , DI1,
  367. > MELEME,NBELEM,JCOLOR)
  368. ELSE IF(SIGN(UN,DI3).NE.SIGN(UN,DINDEX))THEN
  369. C POINTE N.3
  370. CALL COUPEI(XYZ(1,3),XYZ(1,4),XYZ(1,1),XYZ(1,2),
  371. > DI3 , DI4 , DI1 , DI2,
  372. > MELEME,NBELEM,JCOLOR)
  373. ELSE IF(SIGN(UN,DI4).NE.SIGN(UN,DINDEX))THEN
  374. C POINTE N.4
  375. CALL COUPEI(XYZ(1,4),XYZ(1,1),XYZ(1,2),XYZ(1,3),
  376. > DI4 , DI1 , DI2 , DI3,
  377. > MELEME,NBELEM,JCOLOR)
  378. C ERREUR
  379. ELSE
  380. C A FAIRE......
  381. ENDIF
  382. ELSEIF(ABS(DINDEX).EQ.ZERO)THEN
  383. C INTERSECTION PAR UN COTE
  384. IF(SIGN(UN,DI1).EQ.SIGN(UN,DI2))THEN
  385. C COTE 12
  386. CALL COUPEJ(XYZ(1,1),XYZ(1,2),XYZ(1,3),XYZ(1,4),
  387. > DI1 , DI2 , DI3 , DI4,
  388. > MELEME,NBELEM,JCOLOR)
  389. ELSE IF(SIGN(UN,DI1).EQ.SIGN(UN,DI3))THEN
  390. C COTE 13
  391. CALL COUPEJ(XYZ(1,1),XYZ(1,3),XYZ(1,2),XYZ(1,4),
  392. > DI1 , DI3 , DI2 , DI4,
  393. > MELEME,NBELEM,JCOLOR)
  394. ELSE IF(SIGN(UN,DI1).EQ.SIGN(UN,DI4))THEN
  395. C COTE 14
  396. CALL COUPEJ(XYZ(1,1),XYZ(1,4),XYZ(1,2),XYZ(1,3),
  397. > DI1 , DI4 , DI2 , DI3,
  398. > MELEME,NBELEM,JCOLOR)
  399. ELSE IF(SIGN(UN,DI2).EQ.SIGN(UN,DI3))THEN
  400. C COTE 23
  401. CALL COUPEJ(XYZ(1,2),XYZ(1,3),XYZ(1,1),XYZ(1,4),
  402. > DI2 , DI3 , DI1 , DI4,
  403. > MELEME,NBELEM,JCOLOR)
  404. ELSE IF(SIGN(UN,DI2).EQ.SIGN(UN,DI4))THEN
  405. C COTE 24
  406. CALL COUPEJ(XYZ(1,2),XYZ(1,4),XYZ(1,1),XYZ(1,3),
  407. > DI2 , DI4 , DI1 , DI3,
  408. > MELEME,NBELEM,JCOLOR)
  409. ELSE IF(SIGN(UN,DI3).EQ.SIGN(UN,DI4))THEN
  410. C COTE 34
  411. CALL COUPEJ(XYZ(1,3),XYZ(1,4),XYZ(1,1),XYZ(1,2),
  412. > DI3 , DI4 , DI1 , DI2,
  413. > MELEME,NBELEM,JCOLOR)
  414. C ERREUR
  415. ELSE
  416. C A FAIRE......
  417. ENDIF
  418. ENDIF
  419. ENDIF
  420. ENDDO
  421. SEGADJ,MELEME
  422. C ELIMINATION DES DOUBLONS (FACE DANS LE PLAN)
  423. C (on fait un tri prealable)
  424. JG=NBELEM
  425. SEGINI,MLENT1,MLENTI
  426. DO IE2=1,NBELEM
  427. LECT(IE2)=IE2
  428. MLENT1.LECT(IE2)=0
  429. DO IE3=1,NBNN
  430. MLENT1.LECT(IE2)=MLENT1.LECT(IE2)+NUM(IE3,IE2)
  431. ENDDO
  432. ENDDO
  433. SEGINI,MLENT2=MLENTI
  434. C
  435. CALL GENOR2(MLENT1.LECT,MLENT2.LECT,NBELEM)
  436. C
  437. IDIMP1=IDIM+1
  438. NBPTS=XCOOR(/1)/IDIMP1
  439. CALL COUPEN(NUM,NBNN,NBELEM,XCOOR,IDIMP1,NBPTS,
  440. > MLENT1.LECT,MLENT2.LECT,LECT)
  441. C
  442. MBELEM=0
  443. DO IE2=1,NBELEM
  444. IF(LECT(IE2).NE.0)THEN
  445. IF(LECT(IE2).NE.IE2)THEN
  446. LECT(LECT(IE2))=0
  447. ENDIF
  448. MBELEM=MBELEM+1
  449. DO IE3=1,NBNN
  450. NUM(IE3,MBELEM)=NUM(IE3,IE2)
  451. ENDDO
  452. ICOLOR(MBELEM) =ICOLOR(IE2)
  453. ENDIF
  454. ENDDO
  455. C
  456. SEGSUP,MLENTI,MLENT1,MLENT2
  457. NBELEM=MBELEM
  458. SEGADJ,MELEME
  459. C
  460. ELSE
  461. C
  462. C --> ERREUR
  463. C
  464. WRITE(IOIMP,*)'COUPE: Incorrect type of element',ITYP
  465. SEGSUP,MELEME
  466. IF(IE1.GT.1)THEN
  467. DO IE2=1,IE1-1
  468. MELEME=IPT2.LISOUS(IE2)
  469. SEGSUP,MELEME
  470. ENDDO
  471. ENDIF
  472. SEGSUP,IPT2
  473. CALL ERREUR(0)
  474. RETURN
  475. ENDIF
  476. C
  477. C FIN BOUCLE SUR LES ZONES DU MAILLAGE
  478. C
  479. C SEGDES,MELEME
  480. IPT2.LISOUS(IE1)=MELEME
  481. IF(ITYQ.NE.0)SEGSUP,IPT1
  482. ENDDO
  483. C
  484. C ON TASSE LE MAILLAGE POUR ELIMINER LES ZONES VIDES
  485. C
  486. MELEME=IPT2
  487. NBSOUS=0
  488. DO IE1=1,LISOUS(/1)
  489. IPT1=LISOUS(IE1)
  490. NBELEM=IPT1.NUM(/2)
  491. IF(NBELEM.EQ.0)THEN
  492. SEGSUP,IPT1
  493. ELSE
  494. NBSOUS=NBSOUS+1
  495. LISOUS(NBSOUS)=IPT1
  496. SEGDES,IPT1
  497. ENDIF
  498. ENDDO
  499. NBNN=0
  500. NBELEM=0
  501. NBREF=0
  502. SEGADJ,MELEME
  503. C
  504. C SI LE MAILLAGE NE CONTIENT QU'UNE SEULE ZONE...
  505. C
  506. IF(NBSOUS.EQ.1)THEN
  507. IPT1=LISOUS(1)
  508. SEGSUP,MELEME
  509. MELEME=IPT1
  510. ELSE
  511. SEGDES,MELEME
  512. ENDIF
  513. C
  514. CALL ECROBJ('MAILLAGE',MELEME)
  515. RETURN
  516. END
  517.  
  518.  
  519.  
  520.  
  521.  
  522.  
  523.  

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