Télécharger faced2.eso

Retour à la liste

Numérotation des lignes :

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

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