Télécharger faced.eso

Retour à la liste

Numérotation des lignes :

  1. C FACED SOURCE GOUNAND 16/08/24 21:15:01 9050
  2. C TRACE D'UN OBJET PAR FACE EN COMMENCANT PAR CELLES DE DERRIERE
  3. C
  4. C imod=0 trace en couleur d'effacement
  5. C imod=1 trace en couleir normale
  6. C SG 2016/07/18 Programmation comme envvo2 pour gerer les faces TRI7/QUA9
  7. C
  8. SUBROUTINE FACED(MELEME,XPROJ,ICPR,IVU,MCOUP,KON,LNDEGR,imod)
  9. IMPLICIT INTEGER(I-N)
  10. -INC CCOPTIO
  11. -INC SMELEME
  12. -INC CCGEOME
  13. -INC CCREEL
  14. C+PP DEGRADE OU NON
  15. LOGICAL lndegr
  16. C+PP
  17. SEGMENT XPROJ(3,1)
  18. SEGMENT ICPR(1)
  19. SEGMENT IVU(ITE)
  20. SEGMENT MCOUP(0)
  21. SEGMENT KON(2,NBCON,NMAX)
  22. *
  23. * Type de faces prises en compte: T3, Q4, T6, Q8, POLY, T7, Q9
  24. * Numero dans KDFAC 1 2 3 4 6 7 8
  25. * Pour ne pas se prendre la tête, on numerote pareil que KDFAC
  26. * Pour les 5 (non utilisé), 6 (polygone) et >8, ca restera à 0
  27. * NTYFAC=20, codé en dur dans CCGEOME pour KDFAC
  28. PARAMETER (NTYFAC=20)
  29. * Nb de faces de chaque type, sert également de compteur
  30. SEGMENT NBFAC(NTYFAC)
  31. * Un segment pointant sur les IFACI
  32. SEGMENT IPOFAC(NTYFAC)
  33. * Segment IFACI contenant les noeuds, la couleur et si la face d'un
  34. * type donné est vue ou non
  35. SEGMENT IFACI(NNODE+2,NFACI)
  36. * Nombre de noeuds max pour les polygones
  37. PARAMETER (NNOMAX=14)
  38. *
  39. SEGMENT NSOMP(NFACP)
  40. SEGMENT IFACOL(NFAC)
  41. SEGMENT TFAC(NFAC)
  42. SEGMENT KFAK(NFAC)
  43. SEGMENT NAUX(max(2,NFAC))
  44. DIMENSION XTR(NNOMAX),YTR(NNOMAX),ZTR(NNOMAX),NPTR(NNOMAX)
  45. DIMENSION XTR2(3),YTR2(3),ZTR2(3)
  46. *
  47. *dbg write(ioimp,*) 'coucou faced lndegr=',LNDEGR,' imod=',imod
  48.  
  49. SEGACT MELEME
  50. MELSAU=MELEME
  51. IPT1=MELEME
  52. * IF (MCOUP.NE.0) THEN
  53. * NBNN=0
  54. * NBELEM=0
  55. * NBREF=0
  56. * NBSOUS=LISOUS(/1)-1
  57. * SEGINI IPT1
  58. * DO 5 I=1,NBSOUS
  59. * IPT1.LISOUS(I)=LISOUS(I)
  60. * 5 CONTINUE
  61. * ISCOUP=LISOUS(NBSOUS+1)
  62. * ENDIF
  63. * call ecmail(ipt1,0)
  64. CALL ECROBJ('MAILLAGE',IPT1)
  65. CALL ENVELO
  66. * IF (MCOUP.NE.0) SEGSUP IPT1
  67. CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
  68. IF (IERR.NE.0) RETURN
  69. SEGACT MELEME
  70. * IF (MCOUP.NE.0) THEN
  71. * IF (LISOUS(/1).NE.0) THEN
  72. * NBSOUS=LISOUS(/1)+1
  73. * SEGADJ MELEME
  74. * LISOUS(NBSOUS)=ISCOUP
  75. * ELSE
  76. * NBSOUS=2
  77. * SEGINI IPT1
  78. * IPT1.LISOUS(1)=MELEME
  79. * IPT1.LISOUS(2)=ISCOUP
  80. * MELEME=IPT1
  81. * ENDIF
  82. * ENDIF
  83. SEGACT XPROJ,ICPR
  84. SEGACT KON*MOD
  85. NBCON=KON(/2)
  86. NBCONR=NBCON-1
  87. NBPOIN=XPROJ(/2)
  88. TMIN=xsgran
  89. TMAX=-xsgran
  90. DO 1 I=1,NBPOIN
  91. TMIN=MIN(TMIN,XPROJ(3,I))
  92. TMAX=MAX(TMAX,XPROJ(3,I))
  93. 1 CONTINUE
  94. TDIST=TMAX-TMIN
  95. c
  96. c on compte le nombre d elements dont les faces sont de type 1 2 3 4
  97. c 6 7 8 dans NBFAC, attention à 6 : gestion des polygones
  98. SEGINI NBFAC
  99. IPT1=MELEME
  100. SEGACT MELEME
  101. DO 10 IOB=1,MAX(1,LISOUS(/1))
  102. IF (LISOUS(/1).NE.0) THEN
  103. IPT1=LISOUS(IOB)
  104. SEGACT IPT1
  105. ENDIF
  106. NBELEM=IPT1.NUM(/2)
  107. ILTEL=LTEL(1,IPT1.ITYPEL)
  108. IF (ILTEL.EQ.0) GOTO 12
  109. ILTAD=LTEL(2,IPT1.ITYPEL)
  110. DO 13 IF=1,ILTEL
  111. IFT=LDEL(1,ILTAD+IF-1)
  112. NBFAC(IFT)=NBFAC(IFT)+NBELEM
  113. 13 CONTINUE
  114. 12 CONTINUE
  115. 10 CONTINUE
  116. *
  117. NFACP=NBFAC(6)
  118. SEGINI NSOMP
  119. c==== CREATION DES FACES ==============================================
  120. * Initialisation des IFACI
  121. SEGINI IPOFAC
  122. DO ITYFAC=1,NTYFAC
  123. NNODE=KDFAC(1,ITYFAC)
  124. * Polygone
  125. IF (ITYFAC.EQ.6) NNODE=NNOMAX
  126. IF (NNODE.GT.0) THEN
  127. NFACI=NBFAC(ITYFAC)
  128. SEGINI IFACI
  129. IPOFAC(ITYFAC)=IFACI
  130. ENDIF
  131. ENDDO
  132. c NBFAC sert maintenant de compteur
  133. DO ITYFAC=1,NTYFAC
  134. NBFAC(ITYFAC)=0
  135. ENDDO
  136. ICOUPE=0
  137. DO 50 IOB=1,MAX(1,LISOUS(/1))
  138. IF (LISOUS(/1).NE.0) THEN
  139. IPT1=LISOUS(IOB)
  140. ICOUPE=0
  141. IF (IOB.EQ.LISOUS(/1).AND.MCOUP.NE.0) ICOUPE=1
  142. ENDIF
  143. NBELEM=IPT1.NUM(/2)
  144. ILTEL=LTEL(1,IPT1.ITYPEL)
  145. IF (ILTEL.EQ.0) GOTO 52
  146. ILTAD=LTEL(2,IPT1.ITYPEL)
  147. DO 60 IF=1,ILTEL
  148. ITYFAC=LDEL(1,ILTAD+IF-1)
  149. IAD=LDEL(2,ILTAD+IF-1)
  150. NNODE=KDFAC(1,ITYFAC)
  151. NNODF=NNODE
  152. * Polygone
  153. IF (ITYFAC.EQ.6) THEN
  154. NBNN=IPT1.NUM(/1)
  155. * 23 1
  156. *Erreur dans le module de trace
  157. IF (NBNN.GT.NNOMAX) THEN
  158. CALL ERREUR(23)
  159. RETURN
  160. ENDIF
  161. NNODE=NBNN
  162. NNODF=NNOMAX
  163. ENDIF
  164. IF (NNODE.GT.0) THEN
  165. IFACI=IPOFAC(ITYFAC)
  166. DO 70 IEL=1,NBELEM
  167. NBFAC(ITYFAC)=NBFAC(ITYFAC)+1
  168. j=NBFAC(ITYFAC)
  169. * Polygone
  170. IF (ITYFAC.EQ.6) NSOMP(j)=NNODE
  171. IFACI(NNODF+2,j)=1
  172. DO i=1,NNODE
  173. IFACI(i,j)=ICPR(IPT1.NUM(LFAC(IAD+i-1),IEL))
  174. IF (IVU(IFACI(i,j)).NE.1) IFACI(NNODF+2,j)=0
  175. ENDDO
  176. IFACI(NNODF+1,j)=IPT1.ICOLOR(IEL)
  177. * TRI3 cas des coupes
  178. IF (ITYFAC.EQ.1) THEN
  179. IF (ICOUPE.EQ.1) THEN
  180. IF (MCOUP(IEL)/8.EQ.1) IFACI(NNODF+2,j)=2
  181. IF (MCOUP(IEL)/16.EQ.1) IFACI(NNODF+2,j)=3
  182. ENDIF
  183. ENDIF
  184. 70 CONTINUE
  185. ENDIF
  186. 60 CONTINUE
  187. 52 CONTINUE
  188. IF (LISOUS(/1).NE.0) SEGDES IPT1
  189. 50 CONTINUE
  190. SEGDES MELEME
  191. C IF FAUT MAINTENANT RETASSER ET CLASSER LES TABLEAUX DES FACES
  192. C PROBLEME ELLES NE SONT PAS FORCEMENT DECRITES DE LA MEME FACON
  193. NFAC=0
  194. DO ITYFAC=1,NTYFAC
  195. NFAC=NFAC+NBFAC(ITYFAC)
  196. ENDDO
  197. SEGINI TFAC,KFAK,IFACOL
  198. IFAC=0
  199. DO ITYFAC=1,NTYFAC
  200. NNODE=KDFAC(1,ITYFAC)
  201. IF (ITYFAC.EQ.6) THEN
  202. NNODF=NNOMAX
  203. ELSE
  204. NNODF=NNODE
  205. ENDIF
  206. IF (NNODE.GT.0.OR.ITYFAC.EQ.6) THEN
  207. IFACI=IPOFAC(ITYFAC)
  208. DO I=1,NBFAC(ITYFAC)
  209. IFAC=IFAC+1
  210. * Polygone
  211. IF (ITYFAC.EQ.6) NNODE=NSOMP(I)
  212. XXXX = 0.
  213. DO J=1,NNODE
  214. * ligne suivante : erreur de faced pour poly ?
  215. * XXXX = XXXX + XPROJ(3,ICPR(IFACI(J,I)))
  216. XXXX = XXXX + XPROJ(3,IFACI(J,I))
  217. ENDDO
  218. XXXX=XXXX/NNODE
  219. TFAC(IFAC)=XXXX
  220. IF (IFACI(NNODF+2,I).EQ.1) TFAC(IFAC)=TFAC(IFAC)-TDIST
  221. IFACOL(IFAC)=IFACI(NNODF+1,I)
  222. KFAK(IFAC)=I+((ITYFAC-1)*NFAC)
  223. * TRI3/coupe
  224. IF (ITYFAC.EQ.1) THEN
  225. IF (IFACI(NNODF+2,I).EQ.2) TFAC(I)=TFAC(IFAC)-2*TDIST
  226. IF (IFACI(NNODF+2,I).EQ.3) KFAK(IFAC)=0
  227. ENDIF
  228. ENDDO
  229. ENDIF
  230. ENDDO
  231. C IL N'Y A PLUS QU'A TRIER ET RETASSER KFAK SUIVANT TFAC
  232. SEGINI NAUX
  233. IF (IDIM.EQ.2) GOTO 209
  234. NAUX(1)=1
  235. NAUX(2)=NFAC
  236. IZ=2
  237. 208 IZ=IZ-1
  238. IF (IZ.LE.0) GOTO 209
  239. IPB=NAUX(IZ*2-1)
  240. IPH=NAUX(IZ*2)
  241. IF(IPB.GE.IPH) GOTO 208
  242. JPB=IPB-1
  243. JPH=IPH+1
  244. C CALCUL DU PIVOT
  245. PV=0.
  246. * DO 207 J=IPB,IPH
  247. * PV=PV+TFAC(J)
  248. *207 CONTINUE
  249. * PV=PV/(IPH-IPB+1)
  250. PV=(TFAC(IPB)+TFAC(IPH))/2.
  251. 242 JPB=JPB+1
  252. IF (JPH.EQ.JPB) GOTO 245
  253. IF (TFAC(JPB).LT.PV) GOTO 243
  254. GOTO 242
  255. 243 JPH=JPH-1
  256. IF (JPH.EQ.JPB) GOTO 245
  257. IF (TFAC(JPH).GT.PV) GOTO 244
  258. GOTO 243
  259. 244 IAUX=KFAK(JPB)
  260. IAUXX=IFACOL(JPB)
  261. KFAK(JPB)=KFAK(JPH)
  262. IFACOL(JPB)=IFACOL(JPH)
  263. KFAK(JPH)=IAUX
  264. IFACOL(JPH)=IAUXX
  265. TAUX=TFAC(JPB)
  266. TFAC(JPB)=TFAC(JPH)
  267. TFAC(JPH)=TAUX
  268. GOTO 242
  269. 245 IF (JPB.GE.IPB) GOTO 247
  270. JPB=JPB+1
  271. JPH=JPH+2
  272. GOTO 248
  273. 247 IF (JPH.LE.IPH) GOTO 249
  274. JPB=JPB-2
  275. JPH=JPH-1
  276. GOTO 248
  277. 249 IF (TFAC(JPB).LE.PV) GOTO 250
  278. IF (JPH.EQ.IPH) GOTO 251
  279. 252 JPH=JPH+1
  280. GOTO 248
  281. 250 IF (JPB.EQ.IPB) GOTO 252
  282. 251 JPB=JPB-1
  283. 248 IF (JPB.EQ.IPB) GOTO 253
  284. NAUX(2*IZ)=JPB
  285. IZ=IZ+1
  286. 253 IF (JPH.EQ.IPH) GOTO 208
  287. NAUX(2*IZ)=IPH
  288. NAUX(2*IZ-1)=JPH
  289. IZ=IZ+1
  290. GOTO 208
  291. 209 CONTINUE
  292. C LES FACES SONT CLASSEES DANS KFAK LES FACES ON ETE ELIMINEES PAR
  293. C ENVELO . IL NE RESTE PLUS QU'A TRACER
  294. DO 300 I=1,NFAC
  295. IFF=KFAK(I)
  296. IF (IFF.EQ.0) GOTO 300
  297. IT=(IFF-1)/NFAC
  298. IF=IFF-IT*NFAC
  299. IT=IT+1
  300. IOK=0
  301. *
  302. ITYFAC=IT
  303. NNODE=KDFAC(1,ITYFAC)
  304. IF (ITYFAC.EQ.6) NNODE=NSOMP(IF)
  305. IF (NNODE.GT.0) THEN
  306. IFACI=IPOFAC(ITYFAC)
  307. DO IP=1,NNODE
  308. XTR(IP)=XPROJ(1,IFACI(IP,IF))
  309. YTR(IP)=XPROJ(2,IFACI(IP,IF))
  310. ZTR(IP)=XPROJ(3,IFACI(IP,IF))
  311. NPTR(IP)=IFACI(IP,IF)
  312. IF (IVU(IFACI(IP,IF)).EQ.1) IOK=1
  313. *!! write(ioimp,*) 'ip=',ip,' x y z n iok',xtr(ip),ytr(ip),
  314. *!! $ ztr(ip), iok
  315. ENDDO
  316. ENDIF
  317. IF (IOK.EQ.0) GOTO 300
  318. NP=NNODE
  319. * SG Pour les TRI7,QUA9 seuls les points du contour sont pris en compte
  320. * pour le calcul de la normale et la suppression des points du contour.
  321. IF (ITYFAC.EQ.7.OR.ITYFAC.EQ.8) NP=NP-1
  322. *!! write(ioimp,*) 'np=',np
  323. C DETERMINATION DE LA COULEUR D'APRES L'ORIENTATION DE LA NORMALE
  324. XN=0.
  325. YN=0.
  326. ZN=0.
  327. XDE=XTR(NP)
  328. YDE=YTR(NP)
  329. ZDE=ZTR(NP)
  330. XW1=XTR(1)-XDE
  331. YW1=YTR(1)-YDE
  332. ZW1=ZTR(1)-ZDE
  333. DO 900 I2=2,NP-1
  334. XW2=XTR(I2)-XDE
  335. YW2=YTR(I2)-YDE
  336. ZW2=ZTR(I2)-ZDE
  337. XN=XN+(YW1*ZW2-ZW1*YW2)
  338. YN=YN+(ZW1*XW2-XW1*ZW2)
  339. ZN=ZN+(XW1*YW2-YW1*XW2)
  340. XW1=XW2
  341. YW1=YW2
  342. ZW1=ZW2
  343. 900 CONTINUE
  344. DN=SQRT(XN**2+YN**2+ZN**2)
  345. IF (DN.EQ.0.) DN=1.
  346. ZN=ASIN(ABS(ZN/DN))
  347. C+PP DEGRADE OU NON
  348. IF (lndegr) ZN=REAL(XPI/2.D0)
  349. C+PP
  350. IFACO=IFACOL(I)
  351. if (imod.eq.0) ifaco=8
  352. * SG Pour les TRI7 et QUA9, on choisit de decouper en TRI3 :
  353. * idealement, on aurait mis le calcul de la normale dedans
  354. IF (ITYFAC.EQ.7.OR.ITYFAC.EQ.8) THEN
  355. XTR2(1)=XTR(NP+1)
  356. YTR2(1)=YTR(NP+1)
  357. ZTR2(1)=ZTR(NP+1)
  358. DO IPO=1,NP
  359. IPOP=IPO+1
  360. IF (IPOP.GT.NP) IPOP=1
  361. XTR2(2)=XTR(IPO)
  362. YTR2(2)=YTR(IPO)
  363. ZTR2(2)=ZTR(IPO)
  364. XTR2(3)=XTR(IPOP)
  365. YTR2(3)=YTR(IPOP)
  366. ZTR2(3)=ZTR(IPOP)
  367. CALL TRFACE(3,XTR2,YTR2,ZTR2,ZN,IFACO,IEFF)
  368. if (imod.eq.0) ieff=0
  369. ENDDO
  370. ELSE
  371. CALL TRFACE(NP,XTR,YTR,ZTR,ZN,IFACO,IEFF)
  372. ENDIF
  373.  
  374.  
  375. if (imod.eq.0) ieff=0
  376. C SI IEFF <> 0 IL FAUT METTRE LES TRAITS EN EFFACEMENT
  377. N1=NPTR(NP)
  378. DO 450 IIP=1,NP
  379. N2=NPTR(IIP)
  380. NI=N1
  381. NJ=N2
  382. * 459 CONTINUE
  383. 457 DO 454 K=1,NBCONR
  384. IF (KON(1,K,NI).NE.NJ) GOTO 454
  385. C 8 = EFFACEMENT
  386. KON(2,K,NI)=8
  387. IF (IEFF.EQ.0) KON(2,K,NI)=IFACOL(I)
  388. GOTO 456
  389. 454 CONTINUE
  390. IF (KON(1,NBCON,NI).EQ.0) GOTO 456
  391. NI=KON(1,NBCON,NI)
  392. GOTO 457
  393. 456 CONTINUE
  394. NI=N2
  395. NJ=N1
  396. * 469 CONTINUE
  397. 467 DO 464 K=1,NBCONR
  398. IF (KON(1,K,NI).NE.NJ) GOTO 464
  399. C 8 = EFFACEMENT
  400. KON(2,K,NI)=8
  401. IF (IEFF.EQ.0) KON(2,K,NI)=IFACOL(I)
  402. GOTO 466
  403. 464 CONTINUE
  404. IF (KON(1,NBCON,NI).EQ.0) GOTO 466
  405. NI=KON(1,NBCON,NI)
  406. GOTO 467
  407. 466 CONTINUE
  408. N1=N2
  409. 450 CONTINUE
  410. 300 CONTINUE
  411. C'EST FINI
  412. SEGACT MELEME
  413. IF (LISOUS(/1).NE.0) THEN
  414. NBSOUS=LISOUS(/1)
  415. * IF (MCOUP.NE.0) NBSOUS=NBSOUS-1
  416. DO 490 IO=1,NBSOUS
  417. IPT2=LISOUS(IO)
  418. segact ipt2
  419. if (ipt2.itypel.gt.3.AND.ipt2.itypel.NE.32) SEGSUP IPT2
  420. 490 CONTINUE
  421. ENDIF
  422. if ((itypel.eq.0) .AND. (MELEME .NE. MELSAU)) SEGSUP MELEME
  423. MELEME=MELSAU
  424. SEGDES KON
  425. DO ITYFAC=1,NTYFAC
  426. IFACI=IPOFAC(ITYFAC)
  427. IF (IFACI.NE.0) THEN
  428. SEGSUP IFACI
  429. ENDIF
  430. ENDDO
  431. SEGSUP IPOFAC
  432. SEGSUP NBFAC
  433. SEGSUP NAUX,TFAC,KFAK,IFACOL,NSOMP
  434. RETURN
  435. END
  436.  
  437.  
  438.  
  439.  
  440.  
  441.  
  442.  
  443.  
  444.  
  445.  
  446.  
  447.  
  448.  
  449.  
  450.  
  451.  
  452.  
  453.  
  454.  
  455.  
  456.  
  457.  
  458.  
  459.  
  460.  

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