Télécharger faced2.eso

Retour à la liste

Numérotation des lignes :

  1. C FACED2 SOURCE JC220346 17/08/03 21:15:03 9524
  2. C TRACE D'ISOVALEUR EN COMMENCANT PAR CELLES DE DERRIERE
  3. C
  4. C SG 2016/07/18 Programmation comme faced, envvo2 pour gerer les faces TRI7/QUA9
  5. C
  6. SUBROUTINE FACED2(MELEME,XPROJ,ICPR,VCHC,VCPCHA,PTI,NISO,IVU,
  7. # MCOUP,mcham,BLOK)
  8. * si mchaml est non nul on trace un chamelem aux noeuds
  9. * sinon c'est un champoint
  10. IMPLICIT INTEGER(I-N)
  11. -INC CCOPTIO
  12. -INC SMELEME
  13. -INC CCGEOME
  14. -INC SMCHAML
  15. DIMENSION XX(13),YY(13),ZZ(13),VV(13)
  16. DIMENSION XR(3),YR(3),ZR(3),VR(3)
  17. SEGMENT XPROJ(3,1)
  18. SEGMENT ICPR(1)
  19. SEGMENT VCPCHA(XCOOR(/1)/(IDIM+1))
  20. SEGMENT IPOI1(1,NPOI1)
  21. SEGMENT ISEG2(2,NSEG2)
  22. SEGMENT ISEG3(3,NSEG3)
  23. SEGMENT XPOI1(1,NPOI1)
  24. SEGMENT XSEG2(2,NSEG2)
  25. SEGMENT XSEG3(3,NSEG3)
  26. logical lmvid
  27. *
  28. * Type de faces prises en compte: T3, Q4, T6, Q8, POLY, T7, Q9
  29. * Numero dans KDFAC 1 2 3 4 6 7 8
  30. * Pour ne pas se prendre la tête, on numerote pareil que KDFAC
  31. * Pour les 5 (non utilisé), 6 (polygone) et >8, ca restera à 0
  32. * NTYFAC=20, codé en dur dans CCGEOME pour KDFAC
  33. PARAMETER (NTYFAC=20)
  34. * Nb de faces de chaque type, sert également de compteur
  35. SEGMENT NBFAC(NTYFAC)
  36. * Un segment pointant sur les IFACI et les XFACI
  37. SEGMENT IPOFAC(2,NTYFAC)
  38. * Segment IFACI contenant les noeuds et si la face d'un
  39. * type donné est vue ou non
  40. SEGMENT IFACI(NNODE+1,NFACI)
  41. * Segment XFACI contenant les coordonnees noeuds, la couleur et si la face d'un
  42. * type donné est vue ou non
  43. SEGMENT XFACI(NNODE,NFACI)
  44. * Nombre de noeuds max pour les polygones
  45. PARAMETER (NNOMAX=14)
  46. *
  47. REAL BLOK
  48. *
  49. SEGMENT NSOMP(NFACP)
  50. SEGMENT TFAC(NFAC)
  51. SEGMENT KFAK(NFAC)
  52. SEGMENT NAUX(max(2,NFAC))
  53. SEGMENT IVU(0)
  54. SEGMENT MCOUP(0)
  55. REAL VCHC
  56. DIMENSION VCHC(*)
  57. * Poids pour le calcul de la valeur centrale 6 valeurs TRI6 8
  58. * valeurs QUA8. La somme des poids est egale a 1
  59. PARAMETER (XUS3=1./3.,XMUS4=-0.25,XUS2=0.5)
  60. REAL XPOIDS(14)
  61. * TRI6
  62. DATA XPOIDS/0.,XUS3,0.,XUS3,0.,XUS3,
  63. * QUA8
  64. $ XMUS4,XUS2, XMUS4,XUS2, XMUS4,XUS2, XMUS4,XUS2/
  65. *
  66. *dbg write(ioimp,*) 'coucou faced2 mcham=',mcham
  67. SEGACT MELEME
  68.  
  69. * ipt1=lisous(1)
  70. * segact ipt1
  71. * SEGACT XPROJ,ICPR
  72. MELSAU=MELEME
  73. IPT1=MELEME
  74. melval=ipt1
  75. lmvid=.false.
  76. * write (6,*) ' faced2 velche '
  77. * write (6,*) (velche(ix,1),ix=1,20)
  78. if (mcham.eq.0) then
  79. CALL ECROBJ('MAILLAGE',IPT1)
  80. CALL ENVELO
  81. CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
  82. else
  83. CALL ENVEL1(ipt1,meleme,mcoup)
  84. endif
  85. IF (IERR.NE.0) RETURN
  86.  
  87. SEGACT MELEME
  88. SEGACT XPROJ,ICPR
  89. NBPOIN=XPROJ(/2)
  90. TMIN=1E30
  91. TMAX=-1E30
  92. DO 1 I=1,NBPOIN
  93. TMIN=MIN(TMIN,XPROJ(3,I))
  94. TMAX=MAX(TMAX,XPROJ(3,I))
  95. 1 CONTINUE
  96. TDIST=TMAX-TMIN
  97. NPOI1=0
  98. NSEG2=0
  99. NSEG3=0
  100. c
  101. c on compte le nombre d elements dont les faces sont de type 1 2 3 4
  102. c 6 7 8 dans NBFAC, attention à 6 : gestion des polygones
  103. SEGINI NBFAC
  104. IPT1=MELEME
  105. SEGACT MELEME
  106. DO 10 IOB=1,MAX(1,LISOUS(/1))
  107. IF (LISOUS(/1).NE.0) THEN
  108. IPT1=LISOUS(IOB)
  109. SEGACT IPT1
  110. ENDIF
  111. NBELEM=IPT1.NUM(/2)
  112. ILTEL=LTEL(1,IPT1.ITYPEL)
  113. IF (ILTEL.EQ.0) GOTO 12
  114. ILTAD=LTEL(2,IPT1.ITYPEL)
  115. DO 13 IF=1,ILTEL
  116. IFT=LDEL(1,ILTAD+IF-1)
  117. NBFAC(IFT)=NBFAC(IFT)+NBELEM
  118. 13 CONTINUE
  119. 12 CONTINUE
  120. if (ipt1.itypel.eq.1) npoi1=npoi1+nbelem
  121. if (ipt1.itypel.eq.2) nseg2=nseg2+nbelem
  122. if (ipt1.itypel.eq.3) nseg3=nseg3+nbelem
  123. 10 CONTINUE
  124. *
  125. * WRITE(IOIMP,*) 'NBFAC'
  126. * WRITE (IOIMP,9111) (NBFAC(III),III=1,NTYFAC)
  127. * 9111 FORMAT(5(2X,I6))
  128. NFACP=NBFAC(6)
  129. SEGINI NSOMP
  130. SEGINI ipoi1,iseg2,iseg3
  131. if (mcham.ne.0) SEGINI xpoi1,xseg2,xseg3
  132. c==== CREATION DES FACES ==============================================
  133. * Initialisation des IFACI,XFACI
  134. SEGINI IPOFAC
  135. DO ITYFAC=1,NTYFAC
  136. NNODE=KDFAC(1,ITYFAC)
  137. * Polygone
  138. IF (ITYFAC.EQ.6) NNODE=NNOMAX
  139. IF (NNODE.GT.0) THEN
  140. NFACI=NBFAC(ITYFAC)
  141. SEGINI IFACI
  142. IPOFAC(1,ITYFAC)=IFACI
  143. if (mcham.ne.0) then
  144. segini xfaci
  145. IPOFAC(2,ITYFAC)=xfaci
  146. endif
  147. ENDIF
  148. ENDDO
  149. NPOI1=0
  150. NSEG2=0
  151. NSEG3=0
  152. c NBFAC sert maintenant de compteur
  153. DO ITYFAC=1,NTYFAC
  154. NBFAC(ITYFAC)=0
  155. ENDDO
  156. ICOUPE=0
  157. melval = meleme
  158. DO 50 IOB=1,MAX(1,LISOUS(/1))
  159. IF (LISOUS(/1).NE.0) THEN
  160. IPT1=LISOUS(IOB)
  161. ivm1=0
  162. ivm2=0
  163. melval=meleme
  164. if (mcham.ne.0) then
  165. melval=lisref(iob)
  166. if (melval.eq.0) then
  167. write (6,*) 'reference nulle dans faced2',iob
  168. goto 50
  169. endif
  170. ivm1=velche(/1)
  171. ivm2=velche(/2)
  172. lmvid=(ivm1*ivm2.eq.0)
  173. *sg 2016/08/23 ancienne programmation brutale qui sort de la subroutine
  174. * sans mettre meleme=melsau => segmentation violation plus
  175. * tard
  176. *
  177. * if (ivm1*ivm2.eq.0) return
  178.  
  179. endif
  180. ICOUPE=0
  181. IF (IOB.EQ.LISOUS(/1).AND.MCOUP.NE.0) ICOUPE=1
  182. ENDIF
  183. NBELEM=IPT1.NUM(/2)
  184. NBNN =IPT1.NUM(/1)
  185. ILTEL=LTEL(1,IPT1.ITYPEL)
  186. IF (ILTEL.EQ.0) GOTO 52
  187. ILTAD=LTEL(2,IPT1.ITYPEL)
  188. DO 60 IF=1,ILTEL
  189. ITYFAC=LDEL(1,ILTAD+IF-1)
  190. IAD=LDEL(2,ILTAD+IF-1)
  191. NNODE=KDFAC(1,ITYFAC)
  192. NNODF=NNODE
  193. * Polygone
  194. IF (ITYFAC.EQ.6) THEN
  195. NBNN=IPT1.NUM(/1)
  196. * 23 1
  197. *Erreur dans le module de trace
  198. IF (NBNN.GT.NNOMAX) THEN
  199. CALL ERREUR(23)
  200. RETURN
  201. ENDIF
  202. NNODE=NBNN
  203. NNODF=NNOMAX
  204. ENDIF
  205. IF (NNODE.GT.0) THEN
  206. * WRITE(IOIMP,*) 'ITYFAC=',ITYFAC
  207. IFACI=IPOFAC(1,ITYFAC)
  208. xfaci=IPOFAC(2,ITYFAC)
  209. DO 80 IEL=1,NBELEM
  210. * WRITE(IOIMP,*) 'IEL=',IEL
  211. do 70 inn=1,nbnn
  212. if (icpr(ipt1.num(inn,iel)).eq.0) then
  213. call erreur(23)
  214. goto 80
  215. endif
  216. 70 continue
  217. NBFAC(ITYFAC)=NBFAC(ITYFAC)+1
  218. j=NBFAC(ITYFAC)
  219. * Polygone
  220. IF (ITYFAC.EQ.6) NSOMP(j)=NNODE
  221. IFACI(NNODF+1,j)=1
  222. DO i=1,NNODE
  223. IFACI(i,j)=IPT1.NUM(LFAC(IAD+i-1),IEL)
  224. if (mcham.ne.0.AND.(.not.lmvid)) then
  225. xfaci(i,j)=velche(min(ivm1,LFAC(IAD+i-1)),
  226. > min(ivm2,IEL))
  227. * WRITE(IOIMP,*) 'INODE,IFACI,XFACI=',i,ifaci(i,j)
  228. * $ ,xfaci(i,j)
  229. endif
  230. IF (IVU(ICPR(IFACI(i,j))).NE.1) IFACI(NNODF+1,j)=0
  231. ENDDO
  232. * TRI3 cas des coupes
  233. IF (ITYFAC.EQ.1) THEN
  234. IF (ICOUPE.EQ.1) THEN
  235. IF (MCOUP(IEL)/8.EQ.1) IFACI(NNODF+1,j)=2
  236. IF (MCOUP(IEL)/16.EQ.1) IFACI(NNODF+1,j)=3
  237. ENDIF
  238. ENDIF
  239. 80 CONTINUE
  240. ENDIF
  241. 60 CONTINUE
  242. IF (LISOUS(/1).NE.0) SEGDES IPT1
  243. goto 50
  244. 52 CONTINUE
  245. do 68 iel=1,nbelem
  246. if (ipt1.itypel.eq.1) then
  247. npoi1=npoi1+1
  248. IPOI1(1,NPOI1)=IPT1.NUM(1,IEL)
  249. elseif (ipt1.itypel.eq.2) then
  250. nseg2=nseg2+1
  251. ISEG2(1,NSEG2)=IPT1.NUM(1,IEL)
  252. ISEG2(2,NSEG2)=IPT1.NUM(2,IEL)
  253. elseif (ipt1.itypel.eq.3) then
  254. nseg3=nseg3+1
  255. ISEG3(1,NSEG3)=IPT1.NUM(1,IEL)
  256. ISEG3(2,NSEG3)=IPT1.NUM(2,IEL)
  257. ISEG3(3,NSEG3)=IPT1.NUM(3,IEL)
  258. endif
  259. if (mcham.ne.0.AND.(.not.lmvid)) then
  260. if (ipt1.itypel.eq.1) then
  261. xPOI1(1,NPOI1)=velche(min(ivm1,1),min(ivm2,IEL))
  262. elseif (ipt1.itypel.eq.2) then
  263. xSEG2(1,NSEG2)=velche(min(ivm1,1),min(ivm2,IEL))
  264. xSEG2(2,NSEG2)=velche(min(ivm1,2),min(ivm2,IEL))
  265. elseif (ipt1.itypel.eq.3) then
  266. xSEG3(1,NSEG3)=velche(min(ivm1,1),min(ivm2,IEL))
  267. xSEG3(2,NSEG3)=velche(min(ivm1,2),min(ivm2,IEL))
  268. xSEG3(3,NSEG3)=velche(min(ivm1,3),min(ivm2,IEL))
  269. endif
  270. endif
  271. 68 continue
  272. IF (LISOUS(/1).NE.0) SEGDES IPT1
  273. 50 CONTINUE
  274. SEGDES MELEME
  275. C IF FAUT MAINTENANT RETASSER ET CLASSER LES TABLEAUX DES FACES
  276. C PROBLEME ELLES NE SONT PAS FORCEMENT DECRITES DE LA MEME FACON
  277. NFAC=0
  278. DO ITYFAC=1,NTYFAC
  279. NFAC=NFAC+NBFAC(ITYFAC)
  280. ENDDO
  281. NFAC=NFAC+NPOI1+NSEG2+NSEG3
  282. SEGINI TFAC,KFAK
  283. IFAC=0
  284. ITYEL=0
  285. * D'abord les faces ensuite les segments
  286. DO ITYFAC=1,NTYFAC
  287. NNODE=KDFAC(1,ITYFAC)
  288. IF (ITYFAC.EQ.6) THEN
  289. NNODF=NNOMAX
  290. ELSE
  291. NNODF=NNODE
  292. ENDIF
  293. IF (NNODE.GT.0.OR.ITYFAC.EQ.6) THEN
  294. IFACI=IPOFAC(1,ITYFAC)
  295. DO I=1,NBFAC(ITYFAC)
  296. IFAC=IFAC+1
  297. * Polygone
  298. IF (ITYFAC.EQ.6) NNODE=NSOMP(I)
  299. XXXX = 0.
  300. DO J=1,NNODE
  301. XXXX = XXXX + XPROJ(3,ICPR(IFACI(J,I)))
  302. ENDDO
  303. XXXX=XXXX/NNODE
  304. TFAC(IFAC)=XXXX
  305. IF (IFACI(NNODF+1,I).EQ.1) TFAC(IFAC)=TFAC(IFAC)-TDIST
  306. KFAK(IFAC)=I+(ITYEL*NFAC)
  307. * TRI3/coupe
  308. IF (ITYFAC.EQ.1) THEN
  309. IF (IFACI(NNODF+1,I).EQ.2)
  310. $ TFAC(IFAC)=TFAC(IFAC)-2*TDIST
  311. IF (IFACI(NNODF+1,I).EQ.3) KFAK(IFAC)=0
  312. ENDIF
  313. ENDDO
  314. ENDIF
  315. ITYEL=ITYEL+1
  316. ENDDO
  317. DO I=1,NPOI1
  318. IFAC=IFAC+1
  319. TFAC(IFAC)=XPROJ(3,ICPR(IPOI1(1,I)))
  320. KFAK(IFAC)=I+(ITYEL*NFAC)
  321. ENDDO
  322. ITYEL=ITYEL+1
  323. * SEG2 si NSEG2=0, la boucle est sautee
  324. DO I=1,NSEG2
  325. IFAC=IFAC+1
  326. TFAC(IFAC)=(XPROJ(3,ICPR(ISEG2(1,I)))+
  327. $ XPROJ(3,ICPR(ISEG2(2,I))))/2.
  328. KFAK(IFAC)=I+(ITYEL*NFAC)
  329. *dbg write(ioimp,*) 'ifac,tfac,kfak=',ifac,tfac(ifac),kfak(ifac)
  330. ENDDO
  331. ITYEL=ITYEL+1
  332. * SEG3 dans l'ancien faced2, il y avait /2. ????
  333. DO I=1,NSEG3
  334. IFAC=IFAC+1
  335. TFAC(IFAC)=(XPROJ(3,ICPR(ISEG3(1,I)))+
  336. # XPROJ(3,ICPR(ISEG3(2,I)))+
  337. $ XPROJ(3,ICPR(ISEG3(3,I))))/3.
  338. KFAK(IFAC)=I+(ITYEL*NFAC)
  339. ENDDO
  340. C IL N'Y A PLUS QU'A TRIER ET RETASSER KFAK SUIVANT TFAC
  341. *dbg WRITE (IOIMP,9111) (KFAK(I),TFAC(I),I=1,NFAC)
  342. 9111 FORMAT(5(2X,I6,1X,E12.5))
  343.  
  344. SEGINI NAUX
  345. IF (IDIM.EQ.2) GOTO 209
  346. NAUX(1)=1
  347. NAUX(2)=NFAC
  348. IZ=2
  349. 208 IZ=IZ-1
  350. IF (IZ.LE.0) GOTO 209
  351. IPB=NAUX(IZ*2-1)
  352. IPH=NAUX(IZ*2)
  353. IF(IPB.GE.IPH) GOTO 208
  354. JPB=IPB-1
  355. JPH=IPH+1
  356. C CALCUL DU PIVOT
  357. PV=0.
  358. * DO 207 J=IPB,IPH
  359. * PV=PV+TFAC(J)
  360. *207 CONTINUE
  361. * PV=PV/(IPH-IPB+1)
  362. PV=(TFAC(IPB)+TFAC(IPH))/2.
  363. 242 JPB=JPB+1
  364. IF (JPH.EQ.JPB) GOTO 245
  365. IF (TFAC(JPB).LT.PV) GOTO 243
  366. GOTO 242
  367. 243 JPH=JPH-1
  368. IF (JPH.EQ.JPB) GOTO 245
  369. IF (TFAC(JPH).GT.PV) GOTO 244
  370. GOTO 243
  371. 244 IAUX=KFAK(JPB)
  372. KFAK(JPB)=KFAK(JPH)
  373. KFAK(JPH)=IAUX
  374. TAUX=TFAC(JPB)
  375. TFAC(JPB)=TFAC(JPH)
  376. TFAC(JPH)=TAUX
  377. GOTO 242
  378. 245 IF (JPB.GE.IPB) GOTO 247
  379. JPB=JPB+1
  380. JPH=JPH+2
  381. GOTO 248
  382. 247 IF (JPH.LE.IPH) GOTO 249
  383. JPB=JPB-2
  384. JPH=JPH-1
  385. GOTO 248
  386. 249 IF (TFAC(JPB).LE.PV) GOTO 250
  387. IF (JPH.EQ.IPH) GOTO 251
  388. 252 JPH=JPH+1
  389. GOTO 248
  390. 250 IF (JPB.EQ.IPB) GOTO 252
  391. 251 JPB=JPB-1
  392. 248 IF (JPB.EQ.IPB) GOTO 253
  393. NAUX(2*IZ)=JPB
  394. IZ=IZ+1
  395. 253 IF (JPH.EQ.IPH) GOTO 208
  396. NAUX(2*IZ)=IPH
  397. NAUX(2*IZ-1)=JPH
  398. IZ=IZ+1
  399. GOTO 208
  400. 209 CONTINUE
  401. C LES FACES SONT CLASSEES DANS KFAK LES FACES ON ETE ELIMINEES PAR
  402. C ENVELO . IL NE RESTE PLUS QU'A TRACER
  403. *dbg WRITE (IOIMP,9111) (KFAK(I),TFAC(I),I=1,NFAC)
  404. DO 300 I=1,NFAC
  405. IFF=KFAK(I)
  406. IF (IFF.EQ.0) GOTO 300
  407. IT=(IFF-1)/NFAC
  408. IF=IFF-IT*NFAC
  409. IT=IT+1
  410. IOK=0
  411. *
  412. ITYFAC=IT
  413. *dbg WRITE(IOIMP,*) 'IFAC,ITYFAC=',I,ITYFAC
  414. IF (ITYFAC.GE.1.AND.ITYFAC.LE.NTYFAC) THEN
  415. NNODE=KDFAC(1,ITYFAC)
  416. NNODF=NNODE
  417. * Polygone
  418. IF (ITYFAC.EQ.6) THEN
  419. NNODE=NSOMP(IF)
  420. NNODF=NNOMAX
  421. ENDIF
  422. * A cette etape on doit avoir nnode.gt.0
  423. IF (NNODE.LE.0) THEN
  424. CALL ERREUR(5)
  425. RETURN
  426. ENDIF
  427. IFACI=IPOFAC(1,ITYFAC)
  428. xfaci=IPOFAC(2,ITYFAC)
  429. DO J=1,NNODE
  430. IF (IVU(ICPR(IFACI(J,IF))).EQ.1) IOK=1
  431. ENDDO
  432. IF (IOK.EQ.1) THEN
  433. * Cas du TRI3
  434. IF (ITYFAC.EQ.1) THEN
  435. DO J=1,NNODE
  436. NUPT=IFACI(J, IF)
  437. IDPT=ICPR(NUPT)
  438. XX(J)=XPROJ(1,IDPT)
  439. YY(J)=XPROJ(2,IDPT)
  440. ZZ(J)=XPROJ(3,IDPT)
  441. if (mcham.eq.0) then
  442. VV(J)=VCPCHA(NUPT)
  443. else
  444. VV(J)=xfaci(j,IF)
  445. endif
  446. ENDDO
  447. CALL TRISO(VCHC,XX,YY,ZZ,VV,NNODE,NISO)
  448. * Cas des autres faces. Elles ont pour particularité d'avoir une
  449. * valeur centrale et un contour, on trace avec TCISO par defaut
  450. * On peut aussi faire une boucle de TRISO mais ca donne un
  451. * Postscript plus gros.
  452. ELSE
  453. ICONT=0
  454. ITCISO=1
  455. * La valeur centrale est la moyenne sur les autres noeuds QUA4, POLY
  456. IF (ITYFAC.EQ.2.OR.ITYFAC.EQ.6) THEN
  457. XXM = 0.
  458. YYM = 0.
  459. ZZM = 0.
  460. VVM = 0.
  461. DO J=1,NNODE
  462. NUPT=IFACI(J, IF)
  463. IDPT=ICPR(NUPT)
  464. XXM = XPROJ(1,IDPT) + XXM
  465. YYM = XPROJ(2,IDPT) + YYM
  466. ZZM = XPROJ(3,IDPT) + ZZM
  467. IF (MCHAM.EQ.0) THEN
  468. VVM = VCPCHA(NUPT) + VVM
  469. ELSE
  470. VVM = xfaci(J, IF) + VVM
  471. ENDIF
  472. ENDDO
  473. XXM=XXM/NNODE
  474. YYM=YYM/NNODE
  475. ZZM=ZZM/NNODE
  476. VVM=VVM/NNODE
  477. * La valeur centrale est une moyenne pondérée
  478. ELSEIF (ITYFAC.EQ.3.OR.ITYFAC.EQ.4) THEN
  479. XXM = 0.
  480. YYM = 0.
  481. ZZM = 0.
  482. VVM = 0.
  483. IDEC=0
  484. IF (ITYFAC.EQ.4) IDEC=6
  485. DO J=1,NNODE
  486. NUPT=IFACI(J, IF)
  487. IDPT=ICPR(NUPT)
  488. XXM = XPROJ(1,IDPT)*XPOIDS(J+IDEC) + XXM
  489. YYM = XPROJ(2,IDPT)*XPOIDS(J+IDEC) + YYM
  490. ZZM = XPROJ(3,IDPT)*XPOIDS(J+IDEC) + ZZM
  491. IF (MCHAM.EQ.0) THEN
  492. VVM = VCPCHA(NUPT)*XPOIDS(J+IDEC) + VVM
  493. ELSE
  494. VVM = xfaci(J, IF)*XPOIDS(J+IDEC) + VVM
  495. ENDIF
  496. ENDDO
  497. * La valeur centrale est celle du dernier noeud (faces TRI7/QUA9)
  498. ELSEIF (ITYFAC.EQ.7.OR.ITYFAC.EQ.8) THEN
  499. * write(ioimp,*) 'coucou ityfac=',ityfac
  500. NUPT=IFACI(NNODE, IF)
  501. IDPT=ICPR(NUPT)
  502. XXM = XPROJ(1,IDPT)
  503. YYM = XPROJ(2,IDPT)
  504. ZZM = XPROJ(3,IDPT)
  505. IF (MCHAM.EQ.0) THEN
  506. VVM = VCPCHA(NUPT)
  507. * write(ioimp,*) 'vvm=',vvm
  508. ELSE
  509. VVM = xfaci(NNODE, IF)
  510. * write(ioimp,*) 'vvm=',vvm
  511. ENDIF
  512. * On met ICONT à 1 pour ne pas mettre le dernier noeud dans le contour
  513. ICONT=1
  514. *!!!
  515. ITCISO=1
  516. ELSE
  517. write(ioimp,*) 'ITYFAC=',ityfac,' non prevu'
  518. call erreur(5)
  519. return
  520. ENDIF
  521. XX(1)=XXM
  522. YY(1)=YYM
  523. ZZ(1)=ZZM
  524. VV(1)=VVM
  525. DO J=1,NNODE-ICONT
  526. JP=J+1
  527. NUPT=IFACI(J, IF)
  528. IDPT=ICPR(NUPT)
  529. XX(JP) = XPROJ(1,IDPT)
  530. YY(JP) = XPROJ(2,IDPT)
  531. ZZ(JP) = XPROJ(3,IDPT)
  532. IF (MCHAM.EQ.0) THEN
  533. VV(JP) = VCPCHA(NUPT)
  534. ELSE
  535. VV(JP) = xfaci(J, IF)
  536. ENDIF
  537. ENDDO
  538. IF (ITCISO.EQ.1) THEN
  539. CALL TCISO(VCHC,XX,YY,ZZ,VV,NNODE-ICONT+1,NISO)
  540. ELSE
  541. XR(1)=XX(1)
  542. YR(1)=YY(1)
  543. ZR(1)=ZZ(1)
  544. VR(1)=VV(1)
  545. JMAX=NNODE-ICONT
  546. DO J=1,JMAX
  547. JP=J+1
  548. IF (JP.GT.JMAX) JP=1
  549. IA=J+1
  550. IB=JP+1
  551. XR(2)=XX(IA)
  552. YR(2)=YY(IA)
  553. ZR(2)=ZZ(IA)
  554. VR(2)=VV(IA)
  555. XR(3)=XX(IB)
  556. YR(3)=YY(IB)
  557. ZR(3)=ZZ(IB)
  558. VR(3)=VV(IB)
  559. CALL TRISO(VCHC,XR,YR,ZR,VR,3,NISO)
  560. ENDDO
  561. ENDIF
  562. ENDIF
  563. ENDIF
  564. * Cas des POI1
  565. ELSEIF (ITYFAC.EQ.NTYFAC+1) THEN
  566. NNODE=2
  567. IF (IVU(ICPR(IPOI1(1,IF))).EQ.1) IOK=1
  568. IF (IOK.EQ.1) THEN
  569. NUPT=IPOI1(1,IF)
  570. IDPT=ICPR(NUPT)
  571.  
  572. if (mcham.eq.0) then
  573. VV(1)=VCPCHA(NUPT)
  574. VV(2)=VV(1)
  575. else
  576. VV(1)=xpoi1(1,IF)
  577. VV(2)=VV(1)
  578. endif
  579.  
  580. XX(1)=XPROJ(1,IDPT)+BLOK
  581. YY(1)=XPROJ(2,IDPT)
  582. ZZ(1)=XPROJ(3,IDPT)
  583. XX(2)=XPROJ(1,IDPT)-BLOK
  584. YY(2)=XPROJ(2,IDPT)
  585. ZZ(2)=XPROJ(3,IDPT)
  586. CALL TRISO(VCHC,XX,YY,ZZ,VV,NNODE,NISO)
  587.  
  588. XX(1)=XPROJ(1,IDPT)
  589. YY(1)=XPROJ(2,IDPT)+BLOK
  590. ZZ(1)=XPROJ(3,IDPT)
  591. XX(2)=XPROJ(1,IDPT)
  592. YY(2)=XPROJ(2,IDPT)-BLOK
  593. ZZ(2)=XPROJ(3,IDPT)
  594. CALL TRISO(VCHC,XX,YY,ZZ,VV,NNODE,NISO)
  595. ENDIF
  596. * Cas des SEG2
  597. ELSEIF (ITYFAC.EQ.NTYFAC+2) THEN
  598. NNODE=2
  599. DO J=1,NNODE
  600. IF (IVU(ICPR(ISEG2(J,IF))).EQ.1) IOK=1
  601. ENDDO
  602. IF (IOK.EQ.1) THEN
  603. DO J=1,NNODE
  604. NUPT=ISEG2(J, IF)
  605. IDPT=ICPR(NUPT)
  606. XX(J)=XPROJ(1,IDPT)
  607. YY(J)=XPROJ(2,IDPT)
  608. ZZ(J)=XPROJ(3,IDPT)
  609. if (mcham.eq.0) then
  610. VV(J)=VCPCHA(NUPT)
  611. else
  612. VV(J)=xseg2(j,IF)
  613. endif
  614. ENDDO
  615. CALL TRISO(VCHC,XX,YY,ZZ,VV,NNODE,NISO)
  616. ENDIF
  617. * Cas des SEG3
  618. ELSEIF (ITYFAC.EQ.NTYFAC+3) THEN
  619. * 2 SEG2 !
  620. DO ISEG=1,2
  621. isegm=iseg-1
  622. IOK=0
  623. DO J=1,2
  624. IF (IVU(ICPR(ISEG3(J+isegm,IF))).EQ.1) IOK=1
  625. ENDDO
  626. IF (IOK.EQ.1) THEN
  627. DO J=1,2
  628. NUPT=ISEG3(J+isegm, IF)
  629. IDPT=ICPR(NUPT)
  630. XX(J)=XPROJ(1,IDPT)
  631. YY(J)=XPROJ(2,IDPT)
  632. ZZ(J)=XPROJ(3,IDPT)
  633. if (mcham.eq.0) then
  634. VV(J)=VCPCHA(NUPT)
  635. else
  636. VV(J)=xseg3(j+isegm,IF)
  637. endif
  638. ENDDO
  639. CALL TRISO(VCHC,XX,YY,ZZ,VV,2,NISO)
  640. ENDIF
  641. ENDDO
  642. ELSE
  643. write(ioimp,*) 'ITYFAC=',ITYFAC,' non prevu'
  644. call erreur(5)
  645. return
  646. ENDIF
  647. 300 CONTINUE
  648. C 'EST FINI
  649. SEGACT MELEME
  650. IF (LISOUS(/1).NE.0) THEN
  651. NBSOUS=LISOUS(/1)
  652. IF (MCOUP.NE.0) NBSOUS=NBSOUS-1
  653. DO 490 IO=1,NBSOUS
  654. IPT2=LISOUS(IO)
  655. segact ipt2
  656. if (ipt2.itypel.gt.3.AND.ipt2.itypel.NE.32) then
  657. SEGSUP IPT2
  658. if (mcham.ne.0) then
  659. melval=lisref(io)
  660. if (melval.ne.0) segsup melval
  661. endif
  662. else
  663. segdes ipt2
  664. endif
  665. 490 CONTINUE
  666. ENDIF
  667. if (itypel.eq.0) SEGSUP MELEME
  668. MELEME=MELSAU
  669. SEGSUP TFAC,KFAK
  670. SEGSUP NAUX
  671. SEGSUP IPOI1,ISEG2,ISEG3
  672. if (mcham.ne.0) SEGSUP XPOI1,XSEG2,XSEG3
  673. SEGSUP NSOMP
  674. DO ITYFAC=1,NTYFAC
  675. IFACI=IPOFAC(1,ITYFAC)
  676. IF (IFACI.NE.0) THEN
  677. SEGSUP IFACI
  678. ENDIF
  679. xfaci=IPOFAC(2,ITYFAC)
  680. IF (XFACI.NE.0) THEN
  681. SEGSUP XFACI
  682. ENDIF
  683. ENDDO
  684. SEGSUP IPOFAC
  685. SEGSUP NBFAC
  686. RETURN
  687. END
  688.  
  689.  
  690.  
  691.  
  692.  
  693.  
  694.  

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