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=
    IF (IOB.EQ.LISOUS(/1).AND.MCOUP.NE.0) ICOUPE=1
  181. ENDIF
  182. NBELEM=IPT1.NUM(/2)
  183. NBNN =IPT1.NUM(/1)
  184. ILTEL=LTEL(1,IPT1.ITYPEL)
  185. IF (ILTEL.EQ.0) GOTO 52
  186. ILTAD=LTEL(2,IPT1.ITYPEL)
  187. DO 60 IF=1,ILTEL
  188. ITYFAC=LDEL(1,ILTAD+IF-1)
  189. IAD=LDEL(2,ILTAD+IF-1)
  190. NNODE=KDFAC(1,ITYFAC)
  191. NNODF=NNODE
  192. * Polygone
  193. IF (ITYFAC.EQ.6) THEN
  194. NBNN=IPT1.NUM(/1)
  195. * 23 1
  196. *Erreur dans le module de trace
  197. IF (NBNN.GT.NNOMAX) THEN
  198. CALL ERREUR(23)
  199. RETURN
  200. ENDIF
  201. NNODE=NBNN
  202. NNODF=NNOMAX
  203. ENDIF
  204. IF (NNODE.GT.0) THEN
  205. * WRITE(IOIMP,*) 'ITYFAC=',ITYFAC
  206. IFACI=IPOFAC(1,ITYFAC)
  207. xfaci=IPOFAC(2,ITYFAC)
  208. DO 80 IEL=1,NBELEM
  209. * WRITE(IOIMP,*) 'IEL=',IEL
  210. do 70 inn=1,nbnn
  211. if (icpr(ipt1.num(inn,iel)).eq.0) then
  212. call erreur(23)
  213. goto 80
  214. endif
  215. 70 continue
  216. NBFAC(ITYFAC)=NBFAC(ITYFAC)+1
  217. j=NBFAC(ITYFAC)
  218. * Polygone
  219. IF (ITYFAC.EQ.6) NSOMP(j)=NNODE
  220. IFACI(NNODF+1,j)=1
  221. DO i=1,NNODE
  222. IFACI(i,j)=IPT1.NUM(LFAC(IAD+i-1),IEL)
  223. if (mcham.ne.0.AND.(.not.lmvid)) then
  224. xfaci(i,j)=velche(min(ivm1,LFAC(IAD+i-1)),
  225. > min(ivm2,IEL))
  226. * WRITE(IOIMP,*) 'INODE,IFACI,XFACI=',i,ifaci(i,j)
  227. * $ ,xfaci(i,j)
  228. endif
  229. IF (IVU(ICPR(IFACI(i,j))).NE.1) IFACI(NNODF+1,j)=0
  230. ENDDO
  231. * TRI3 cas des coupes
  232. IF (ITYFAC.EQ.1) THEN
  233. IF (ICOUPE.EQ.1) THEN
  234. IF (MCOUP(IEL)/8.EQ.1) IFACI(NNODF+1,j)=2
  235. IF (MCOUP(IEL)/16.EQ.1) IFACI(NNODF+1,j)=3
  236. ENDIF
  237. ENDIF
  238. 80 CONTINUE
  239. ENDIF
  240. 60 CONTINUE
  241. IF (LISOUS(/1).NE.0) SEGDES IPT1
  242. goto 50
  243. 52 CONTINUE
  244. do 68 iel=1,nbelem
  245. if (ipt1.itypel.eq.1) then
  246. npoi1=npoi1+1
  247. IPOI1(1,NPOI1)=IPT1.NUM(1,IEL)
  248. elseif (ipt1.itypel.eq.2) then
  249. nseg2=nseg2+1
  250. ISEG2(1,NSEG2)=IPT1.NUM(1,IEL)
  251. ISEG2(2,NSEG2)=IPT1.NUM(2,IEL)
  252. elseif (ipt1.itypel.eq.3) then
  253. nseg3=nseg3+1
  254. ISEG3(1,NSEG3)=IPT1.NUM(1,IEL)
  255. ISEG3(2,NSEG3)=IPT1.NUM(2,IEL)
  256. ISEG3(3,NSEG3)=IPT1.NUM(3,IEL)
  257. endif
  258. if (mcham.ne.0.AND.(.not.lmvid)) then
  259. if (ipt1.itypel.eq.1) then
  260. xPOI1(1,NPOI1)=velche(min(ivm1,1),min(ivm2,IEL))
  261. elseif (ipt1.itypel.eq.2) then
  262. xSEG2(1,NSEG2)=velche(min(ivm1,1),min(ivm2,IEL))
  263. xSEG2(2,NSEG2)=velche(min(ivm1,2),min(ivm2,IEL))
  264. elseif (ipt1.itypel.eq.3) then
  265. xSEG3(1,NSEG3)=velche(min(ivm1,1),min(ivm2,IEL))
  266. xSEG3(2,NSEG3)=velche(min(ivm1,2),min(ivm2,IEL))
  267. xSEG3(3,NSEG3)=velche(min(ivm1,3),min(ivm2,IEL))
  268. endif
  269. endif
  270. 68 continue
  271. IF (LISOUS(/1).NE.0) SEGDES IPT1
  272. 50 CONTINUE
  273. SEGDES MELEME
  274. C IF FAUT MAINTENANT RETASSER ET CLASSER LES TABLEAUX DES FACES
  275. C PROBLEME ELLES NE SONT PAS FORCEMENT DECRITES DE LA MEME FACON
  276. NFAC=0
  277. DO ITYFAC=1,NTYFAC
  278. NFAC=NFAC+NBFAC°;)
  279. ENDDO
  280. NFAC=NFAC+NPOI1+NSEG2+NSEG3
  281. SEGINI TFAC,KFAK
  282. IFAC=0
  283. ITYEL=0
  284. * D'abord les faces ensuite les segments
  285. DO ITYFAC=1,NTYFAC
  286. NNODE=KDFAC(1,ITYFAC)
  287. IF (ITYFAC.EQ.6) THEN
  288. NNODF=NNOMAX
  289. ELSE
  290. NNODF=NNODE
  291. ENDIF
  292. IF (NNODE.GT.0.OR.ITYFAC.EQ.6) THEN
  293. IFACI=IPOFAC(1,ITYFAC)
  294. DO I=1,NBFAC(ITYFAC)
  295. IFAC=IFAC+1
  296. * Polygone
  297. IF (ITYFAC.EQ.6) NNODE=NSOMP(I)
  298. XXXX = 0.
  299. DO J=1,NNODE
  300. XXXX = XXXX + XPROJ(3,ICPR(IFACI(J,I)))
  301. ENDDO
  302. XXXX=XXXX/NNODE
  303. TFAC(IFAC)=XXXX
  304. IF (IFACI(NNODF+1,I).EQ.1) TFAC(IFAC)=TFAC(IFAC)-TDIST
  305. KFAK(IFAC)=I+(ITYEL*NFAC)
  306. * TRI3/coupe
  307. IF (ITYFAC.EQ.1) THEN
  308. IF (IFACI(NNODF+1,I).EQ.2)
  309. $ TFAC(IFAC)=TFAC(IFAC)-2*TDIST
  310. IF (IFACI(NNODF+1,I).EQ.3) KFAK(IFAC)=0
  311. ENDIF
  312. ENDDO
  313. ENDIF
  314. ITYEL=ITYEL+1
  315. ENDDO
  316. DO I=1,NPOI1
  317. IFAC=IFAC+1
  318. TFAC(IFAC)=XPROJ(3,ICPR(IPOI1(1,I)))
  319. KFAK(IFAC)=I+(ITYEL*NFAC)
  320. ENDDO
  321. ITYEL=ITYEL+1
  322. * SEG2 si NSEG2=0, la boucle est sautee
  323. DO I=1,NSEG2
  324. IFAC=IFAC+1
  325. TFAC(IFAC)=(XPROJ(3,ICPR(ISEG2(1,I)))+
  326. $ XPROJ(3,ICPR(ISEG2(2,I))))/2.
  327. KFAK(IFAC)=I+(ITYEL*NFAC)
  328. *dbg write(ioimp,*) 'ifac,tfac,kfak=',ifac,tfac(ifac),kfak(ifac)
  329. ENDDO
  330. ITYEL=ITYEL+1
  331. * SEG3 dans l'ancien faced2, il y avait /2. ????
  332. DO I=1,NSEG3
  333. IFAC=IFAC+1
  334. TFAC(IFAC)=(XPROJ(3,ICPR(ISEG3(1,I)))+
  335. # XPROJ(3,ICPR(ISEG3(2,I)))+
  336. $ XPROJ(3,ICPR(ISEG3(3,I))))/3.
  337. KFAK(IFAC)=I+(ITYEL*NFAC)
  338. ENDDO
  339. C IL N'Y A PLUS QU'A TRIER ET RETASSER KFAK SUIVANT TFAC
  340. *dbg WRITE (IOIMP,9111) (KFAK(I),TFAC(I),I=1,NFAC)
  341. 9111 FORMAT(5(2X,I6,1X,E12.5))
  342.  
  343. SEGINI NAUX
  344. IF (IDIM.EQ.2) GOTO 209
  345. NAUX(1)=1
  346. NAUX(2)=NFAC
  347. IZ=2
  348. 208 IZ=IZ-1
  349. IF (IZ.LE.0) GOTO 209
  350. IPB=NAUX(IZ*2-1)
  351. IPH=NAUX(IZ*2)
  352. IF(IPB.GE.IPH) GOTO 208
  353. JPB=IPB-1
  354. JPH=IPH+1
  355. C CALCUL DU PIVOT
  356. PV=0.
  357. * DO 207 J=IPB,IPH
  358. * PV=PV+TFAC(J)
  359. *207 CONTINUE
  360. * PV=PV/(IPH-IPB+1)
  361. PV=(TFAC(IPB)+TFAC(IPH))/2.
  362. 242 JPB=JPB+1
  363. IF (JPH.EQ.JPB) GOTO 245
  364. IF (TFAC(JPB).LT.PV) GOTO 243
  365. GOTO 242
  366. 243 JPH=JPH-1
  367. IF (JPH.EQ.JPB) GOTO 245
  368. IF (TFAC(JPH).GT.PV) GOTO 244
  369. GOTO 243
  370. 244 IAUX=KFAK(JPB)
  371. KFAK(JPB)=KFAK(JPH)
  372. KFAK(JPH)=IAUX
  373. TAUX=TFAC(JPB)
  374. TFAC(JPB)=TFAC(JPH)
  375. TFAC(JPH)=TAUX
  376. GOTO 242
  377. 245 IF (JPB.GE.IPB) GOTO 247
  378. JPB=JPB+1
  379. JPH=JPH+2
  380. GOTO 248
  381. 247 IF (JPH.LE.IPH) GOTO 249
  382. JPB=JPB-2
  383. JPH=JPH-1
  384. GOTO 248
  385. 249 IF (TFAC(JPB).LE.PV) GOTO 250
  386. IF (JPH.EQ.IPH) GOTO 251
  387. 252 JPH=JPH+1
  388. GOTO 248
  389. 250 IF (JPB.EQ.IPB) GOTO 252
  390. 251 JPB=JPB-1
  391. 248 IF (JPB.EQ.IPB) GOTO 253
  392. NAUX(2*IZ)=JPB
  393. IZ=IZ+1
  394. 253 IF (JPH.EQ.IPH) GOTO 208
  395. NAUX(2*IZ)=IPH
  396. NAUX(2*IZ-1)=JPH
  397. IZ=IZ+1
  398. GOTO 208
  399. 209 CONTINUE
  400. C LES FACES SONT CLASSEES DANS KFAK LES FACES ON ETE ELIMINEES PAR
  401. C ENVELO . IL NE RESTE PLUS QU'A TRACER
  402. *dbg WRITE (IOIMP,9111) (KFAK(I),TFAC(I),I=1,NFAC)
  403. DO 300 I=1,NFAC
  404. IFF=KFAK(I)
  405. IF (IFF.EQ.0) GOTO 300
  406. IT=(IFF-1)/NFAC
  407. IF=IFF-IT*NFAC
  408. IT=IT+1
  409. IOK=0
  410. *
  411. ITYFAC=IT
  412. *dbg WRITE(IOIMP,*) 'IFAC,ITYFAC=',I,ITYFAC
  413. IF (ITYFAC.GE.1.AND.ITYFAC.LE.NTYFAC) THEN
  414. NNODE=KDFAC(1,ITYFAC)
  415. NNODF=NNODE
  416. * Polygone
  417. IF (ITYFAC.EQ.6) THEN
  418. NNODE=NSOMP(IF)
  419. NNODF=NNOMAX
  420. ENDIF
  421. * A cette etape on doit avoir nnode.gt.0
  422. IF (NNODE.LE.0) THEN
  423. CALL ERREUR(5)
  424. RETURN
  425. ENDIF
  426. IFACI=IPOFAC(1,ITYFAC)
  427. xfaci=IPOFAC(2,ITYFAC)
  428. DO J=1,NNODE
  429. IF (IVU(ICPR(IFACI(J,IF))).EQ.1) IOK=1
  430. ENDDO
  431. IF (IOK.EQ.1) THEN
  432. * Cas du TRI3
  433. IF (ITYFAC.EQ.1) THEN
  434. DO J=1,NNODE
  435. NUPT=IFACI(J, IF)
  436. IDPT=ICPR(NUPT)
  437. XX(J)=XPROJ(1,IDPT)
  438. YY(J)=XPROJ(2,IDPT)
  439. ZZ(J)=XPROJ(3,IDPT)
  440. if (mcham.eq.0) then
  441. VV(J)=VCPCHA(NUPT)
  442. else
  443. VV(J)=xfaci(j,IF)
  444. endif
  445. ENDDO
  446. CALL TRISO(VCHC,XX,YY,ZZ,VV,NNODE,NISO)
  447. * Cas des autres faces. Elles ont pour particularité d'avoir une
  448. * valeur centrale et un contour, on trace avec TCISO par defaut
  449. * On peut aussi faire une boucle de TRISO mais ca donne un
  450. * Postscript plus gros.
  451. ELSE
  452. ICONT=0
  453. ITCISO=1
  454. * La valeur centrale est la moyenne sur les autres noeuds QUA4, POLY
  455. IF (ITYFAC.EQ.2.OR.ITYFAC.EQ.6) THEN
  456. XXM = 0.
  457. YYM = 0.
  458. ZZM = 0.
  459. VVM = 0.
  460. DO J=1,NNODE
  461. NUPT=IFACI(J, IF)
  462. IDPT=ICPR(NUPT)
  463. XXM = XPROJ(1,IDPT) + XXM
  464. YYM = XPROJ(2,IDPT) + YYM
  465. ZZM = XPROJ(3,IDPT) + ZZM
  466. IF (MCHAM.EQ.0) THEN
  467. VVM = VCPCHA(NUPT) + VVM
  468. ELSE
  469. VVM = xfaci(J, IF) + VVM
  470. ENDIF
  471. ENDDO
  472. XXM=XXM/NNODE
  473. YYM=YYM/NNODE
  474. ZZM=ZZM/NNODE
  475. VVM=VVM/NNODE
  476. * La valeur centrale est une moyenne pondérée
  477. ELSEIF (ITYFAC.EQ.3.OR.ITYFAC.EQ.4) THEN
  478. XXM = 0.
  479. YYM = 0.
  480. ZZM = 0.
  481. VVM = 0.
  482. IDEC=0
  483. IF (ITYFAC.EQ.4) IDEC=6
  484. DO J=1,NNODE
  485. NUPT=IFACI(J, IF)
  486. IDPT=ICPR(NUPT)
  487. XXM = XPROJ(1,IDPT)*XPOIDS(J+IDEC) + XXM
  488. YYM = XPROJ(2,IDPT)*XPOIDS(J+IDEC) + YYM
  489. ZZM = XPROJ(3,IDPT)*XPOIDS(J+IDEC) + ZZM
  490. IF (MCHAM.EQ.0) THEN
  491. VVM = VCPCHA(NUPT)*XPOIDS(J+IDEC) + VVM
  492. ELSE
  493. VVM = xfaci(J, IF)*XPOIDS(J+IDEC) + VVM
  494. ENDIF
  495. ENDDO
  496. * La valeur centrale est celle du dernier noeud (faces TRI7/QUA9)
  497. ELSEIF (ITYFAC.EQ.7.OR.ITYFAC.EQ.8) THEN
  498. * write(ioimp,*) 'coucou ityfac=',ityfac
  499. NUPT=IFACI(NNODE, IF)
  500. IDPT=ICPR(NUPT)
  501. XXM = XPROJ(1,IDPT)
  502. YYM = XPROJ(2,IDPT)
  503. ZZM = XPROJ(3,IDPT)
  504. IF (MCHAM.EQ.0) THEN
  505. VVM = VCPCHA(NUPT)
  506. * write(ioimp,*) 'vvm=',vvm
  507. ELSE
  508. VVM = xfaci(NNODE, IF)
  509. * write(ioimp,*) 'vvm=',vvm
  510. ENDIF
  511. * On met ICONT à 1 pour ne pas mettre le dernier noeud dans le contour
  512. ICONT=1
  513. *!!!
  514. ITCISO=1
  515. ELSE
  516. write(ioimp,*) 'ITYFAC=',ityfac,' non prevu'
  517. call erreur(5)
  518. return
  519. ENDIF
  520. XX(1)=XXM
  521. YY(1)=YYM
  522. ZZ(1)=ZZM
  523. VV(1)=VVM
  524. DO J=1,NNODE-ICONT
  525. JP=J+1
  526. NUPT=IFACI(J, IF)
  527. IDPT=ICPR(NUPT)
  528. XX(JP) = XPROJ(1,IDPT)
  529. YY(JP) = XPROJ(2,IDPT)
  530. ZZ(JP) = XPROJ(3,IDPT)
  531. IF (MCHAM.EQ.0) THEN
  532. VV(JP) = VCPCHA(NUPT)
  533. ELSE
  534. VV(JP) = xfaci(J, IF)
  535. ENDIF
  536. ENDDO
  537. IF (ITCISO.EQ.1) THEN
  538. CALL TCISO(VCHC,XX,YY,ZZ,VV,NNODE-ICONT+1,NISO)
  539. ELSE
  540. XR(1)=XX(1)
  541. YR(1)=YY(1)
  542. ZR(1)=ZZ(1)
  543. VR(1)=VV(1)
  544. JMAX=NNODE-ICONT
  545. DO J=1,JMAX
  546. JP=J+1
  547. IF (JP.GT.JMAX) JP=1
  548. IA=J+1
  549. IB=JP+1
  550. XR(2)=XX(IA)
  551. YR(2)=YY(IA)
  552. ZR(2)=ZZ(IA)
  553. VR(2)=VV(IA)
  554. XR(3)=XX(IB)
  555. YR(3)=YY(IB)
  556. ZR(3)=ZZ(IB)
  557. VR(3)=VV(IB)
  558. CALL TRISO(VCHC,XR,YR,ZR,VR,3,NISO)
  559. ENDDO
  560. ENDIF
  561. ENDIF
  562. ENDIF
  563. * Cas des POI1
  564. ELSEIF (ITYFAC.EQ.NTYFAC+1) THEN
  565. NNODE=2
  566. IF (IVU(ICPR(IPOI1(1,IF))).EQ.1) IOK=1
  567. IF (IOK.EQ.1) THEN
  568. NUPT=IPOI1(1,IF)
  569. IDPT=ICPR(NUPT)
  570.  
  571. if (mcham.eq.0) then
  572. VV(1)=VCPCHA(NUPT)
  573. VV(2)=VV(1)
  574. else
  575. VV(1)=xpoi1(1,IF)
  576. VV(2)=VV(1)
  577. endif
  578.  
  579. XX(1)=XPROJ(1,IDPT)+BLOK
  580. YY(1)=XPROJ(2,IDPT)
  581. ZZ(1)=XPROJ(3,IDPT)
  582. XX(2)=XPROJ(1,IDPT)-BLOK
  583. YY(2)=XPROJ(2,IDPT)
  584. ZZ(2)=XPROJ(3,IDPT)
  585. CALL TRISO(VCHC,XX,YY,ZZ,VV,NNODE,NISO)
  586.  
  587. XX(1)=XPROJ(1,IDPT)
  588. YY(1)=XPROJ(2,IDPT)+BLOK
  589. ZZ(1)=XPROJ(3,IDPT)
  590. XX(2)=XPROJ(1,IDPT)
  591. YY(2)=XPROJ(2,IDPT)-BLOK
  592. ZZ(2)=XPROJ(3,IDPT)
  593. CALL TRISO(VCHC,XX,YY,ZZ,VV,NNODE,NISO)
  594. ENDIF
  595. * Cas des SEG2
  596. ELSEIF (ITYFAC.EQ.NTYFAC+2) THEN
  597. NNODE=2
  598. DO J=1,NNODE
  599. IF (IVU(ICPR(ISEG2(J,IF))).EQ.1) IOK=1
  600. ENDDO
  601. IF (IOK.EQ.1) THEN
  602. DO J=1,NNODE
  603. NUPT=ISEG2(J, IF)
  604. IDPT=ICPR(NUPT)
  605. XX(J)=XPROJ(1,IDPT)
  606. YY(J)=XPROJ(2,IDPT)
  607. ZZ(J)=XPROJ(3,IDPT)
  608. if (mcham.eq.0) then
  609. VV(J)=VCPCHA(NUPT)
  610. else
  611. VV(J)=xseg2(j,IF)
  612. endif
  613. ENDDO
  614. CALL TRISO(VCHC,XX,YY,ZZ,VV,NNODE,NISO)
  615. ENDIF
  616. * Cas des SEG3
  617. ELSEIF (ITYFAC.EQ.NTYFAC+3) THEN
  618. * 2 SEG2 !
  619. DO ISEG=1,2
  620. isegm=iseg-1
  621. IOK=0
  622. DO J=1,2
  623. IF (IVU(ICPR(ISEG3(J+isegm,IF))).EQ.1) IOK=1
  624. ENDDO
  625. IF (IOK.EQ.1) THEN
  626. DO J=1,2
  627. NUPT=ISEG3(J+isegm, IF)
  628. IDPT=ICPR(NUPT)
  629. XX(J)=XPROJ(1,IDPT)
  630. YY(J)=XPROJ(2,IDPT)
  631. ZZ(J)=XPROJ(3,IDPT)
  632. if (mcham.eq.0) then
  633. VV(J)=VCPCHA(NUPT)
  634. else
  635. VV(J)=xseg3(j+isegm,IF)
  636. endif
  637. ENDDO
  638. CALL TRISO(VCHC,XX,YY,ZZ,VV,2,NISO)
  639. ENDIF
  640. ENDDO
  641. ELSE
  642. write(ioimp,*) 'ITYFAC=',ITYFAC,' non prevu'
  643. call erreur(5)
  644. return
  645. ENDIF
  646. 300 CONTINUE
  647. C 'EST FINI
  648. SEGACT MELEME
  649. IF (LISOUS(/1).NE.0) THEN
  650. NBSOUS=LISOUS(/1)
  651. IF (MCOUP.NE.0) NBSOUS=NBSOUS-1
  652. DO 490 IO=1,NBSOUS
  653. IPT2=LISOUS(IO)
  654. segact ipt2
  655. if (ipt2.itypel.gt.3.AND.ipt2.itypel.NE.32) then
  656. SEGSUP IPT2
  657. if (mcham.ne.0) then
  658. melval=lisref(io)
  659. if (melval.ne.0) segsup melval
  660. endif
  661. else
  662. segdes ipt2
  663. endif
  664. 490 CONTINUE
  665. ENDIF
  666. if (itypel.eq.0) SEGSUP MELEME
  667. MELEME=MELSAU
  668. SEGSUP TFAC,KFAK
  669. SEGSUP NAUX
  670. SEGSUP IPOI1,ISEG2,ISEG3
  671. if (mcham.ne.0) SEGSUP XPOI1,XSEG2,XSEG3
  672. SEGSUP NSOMP
  673. DO ITYFAC=1,NTYFAC
  674. IFACI=IPOFAC(1,ITYFAC)
  675. IF (IFACI.NE.0) THEN
  676. SEGSUP IFACI
  677. ENDIF
  678. xfaci=IPOFAC(2,ITYFAC)
  679. IF (XFACI.NE.0) THEN
  680. SEGSUP XFACI
  681. ENDIF
  682. ENDDO
  683. SEGSUP IPOFAC
  684. SEGSUP NBFAC
  685. RETURN
  686. END
  687.  
  688.  
  689.  
  690.  
  691.  
  692.  
  693.  

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