Télécharger crcou2.eso

Retour à la liste

Numérotation des lignes :

  1. C CRCOU2 SOURCE BP208322 16/11/18 21:16:00 9177
  2. C CALCUL D'UN OBJET COUPE VIRTUEL (CAS DE DEFORMEES)
  3. C
  4. C CRCOU2 REMPLACE MELEME PAR L'OBJET COUPE
  5. C MCOUP ET LE DERNIER COMPOSANT DE MELEME REMPLACE DECRIVENT
  6. C L'INTERSECTION
  7. C IL FAUDRA METTRE UNE INDICATION AUX TRIANGLES SE TROUVANT DANS LE PLA
  8. C DE COUPE POUR REUSSIR LES PARTIES VUES PARTIES CACHEES
  9. C
  10. C SG 2016/07/18 : traitement du cas des faces tri7/qua9
  11. C
  12. SUBROUTINE CRCOU2(JOEIL,ICOUP1,ICOUP2,ICOUP3,MELEME,MCOUP,VCHCA,
  13. # XCORD,ICPR,MELEM2,MCOU2,ITE,IVU,mchamor,isect)
  14. IMPLICIT INTEGER(I-N)
  15. -INC CCGEOME
  16. -INC CCREEL
  17. -INC CCOPTIO
  18. -INC SMCOORD
  19. -INC SMELEME
  20. -INC SMCHAML
  21. SEGMENT XCORD(IDIM,ITE)
  22. REAL*8 XN,YN,ZN,SIGA,SIGB,SIGC,SIGRAV
  23. * sg
  24. REAL*8 xo,yo,zo,xct,yct,zct,xc2,yc2,zc2,xc3,yc3,zc3
  25. REAL*8 xv,yv,zv,xw,yw,zw
  26. REAL*8 rn,sig,chgrav
  27. * sg
  28. SEGMENT IVU(0)
  29. SEGMENT VCHCA(0)
  30. SEGMENT ITR(0)
  31. SEGMENT ITRT(0)
  32. SEGMENT XTR(0)
  33. SEGMENT XTRT(0)
  34. SEGMENT IQUAT(0)
  35. SEGMENT XQUAT(0)
  36. SEGMENT ISEGM(0)
  37. SEGMENT XSEGM(NBPOIN)
  38. SEGMENT MCOUP(0)
  39. SEGMENT ICPR(0)
  40. SEGMENT IJGRAV(2,100)
  41. DIMENSION JTT(9),ISEG(9)
  42. LOGICAL VOLUM
  43. logical lquaf
  44. *
  45. *dbg write(ioimp,*) 'coucou crcou2 isect,vchca,xcord=',isect,vchca
  46. *dbg $ ,xcord
  47. n2ptel=0
  48. n2el=0
  49. mcham=mchamor
  50. MEDSAU=0
  51. SEGINI ITR,ISEGM,MCOUP,IJGRAV,ITRT,IQUAT
  52. SEGACT XCORD,MCOORD
  53. NBPOIN=XCOOR(/1)/4
  54. if (mcham.ne.0) segini xtr,xtrt,xquat,xsegm
  55. ITE=XCORD(/2)
  56. IREF=(JOEIL-1)*4
  57. XO=XCOOR(IREF+1)
  58. YO=XCOOR(IREF+2)
  59. ZO=XCOOR(IREF+3)
  60. *dbg WRITE(IOIMP,*) 'joeil,x,y,z=',joeil,xo,yo,zo
  61. IREF=(ICOUP1-1)*4
  62. XCT=XCOOR(IREF+1)
  63. YCT=XCOOR(IREF+2)
  64. ZCT=XCOOR(IREF+3)
  65. *dbg WRITE(IOIMP,*) 'icoup1,x,y,z=',icoup1,xct,yct,zct
  66. IREF=(ICOUP2-1)*4
  67. XC2=XCOOR(IREF+1)
  68. YC2=XCOOR(IREF+2)
  69. ZC2=XCOOR(IREF+3)
  70. *dbg WRITE(IOIMP,*) 'icoup2,x,y,z=',icoup2,xc2,yc2,zc2
  71. IREF=(ICOUP3-1)*4
  72. XC3=XCOOR(IREF+1)
  73. YC3=XCOOR(IREF+2)
  74. ZC3=XCOOR(IREF+3)
  75. *dbg WRITE(IOIMP,*) 'icoup3,x,y,z=',icoup3,xc3,yc3,zc3
  76. C NORMALE AU PLAN :
  77. XV=XC2-XCT
  78. YV=YC2-YCT
  79. ZV=ZC2-ZCT
  80. XW=XC3-XCT
  81. YW=YC3-YCT
  82. ZW=ZC3-ZCT
  83. XN=YV*ZW-ZV*YW
  84. YN=ZV*XW-XV*ZW
  85. ZN=XV*YW-YV*XW
  86. RN=XN**2+YN**2+ZN**2
  87. * IF (RN.EQ.0.) CALL ERREUR(21)
  88. IF (ABS(RN).LT.(XPETIT**0.25D0)) CALL ERREUR(21)
  89. IF (IERR.NE.0) RETURN
  90. RN=SQRT(RN)
  91. XN=XN/RN
  92. YN=YN/RN
  93. ZN=ZN/RN
  94. SIG=(XO-XCT)*XN+(YO-YCT)*YN+(ZO-ZCT)*ZN
  95. IF (SIG.LE.0.) THEN
  96. XN=-XN
  97. YN=-YN
  98. ZN=-ZN
  99. ENDIF
  100. * DANS IVU ON NOTE LES POINTS DU MAUVAIS COTE DU PLAN DE COUPE
  101. DO 60 I=1,XCORD(/2)
  102. XP=XCORD(1,I)
  103. YP=XCORD(2,I)
  104. ZP=XCORD(3,I)
  105. SIG=(XP-XCT)*XN+(YP-YCT)*YN+(ZP-ZCT)*ZN
  106. IF (SIG.GT.0.) IVU(I)=0
  107. *dbg WRITE(IOIMP,*) 'I,X,Y,Z,S,IVU=',I,XP,YP,ZP,SIG,IVU(I)
  108. 60 CONTINUE
  109. 5000 CONTINUE
  110. SEGACT MELEME
  111. NBSOU=LISOUS(/1)
  112. NBSOUS=MAX(2,NBSOU+1)
  113. NBREF=0
  114. if (mcham.ne.0) nbref=nbsous
  115. NBNN=0
  116. NBELEM=0
  117. SEGINI IPT8
  118. IPT1=MELEME
  119. ISU=0
  120. * prob optimiseur
  121. melva1=meleme
  122. melva2=meleme
  123. DO 10 ISOUS=1,MAX(1,NBSOU)
  124. IF (NBSOU.NE.0) THEN
  125. IPT1=LISOUS(ISOUS)
  126. if (mcham.ne.0) then
  127. melva1=lisref(isous)
  128. segact melva1
  129. lva1=melva1.velche(/1)
  130. endif
  131. SEGACT IPT1
  132. ENDIF
  133. NBREF=0
  134. NBSOUS=0
  135. NBNN=IPT1.NUM(/1)
  136. NBELEM=IPT1.NUM(/2)
  137. SEGINI IPT2
  138. IPT2.ITYPEL=IPT1.ITYPEL
  139. if (mcham.ne.0) then
  140. n1ptel=nbnn
  141. n1el=nbelem
  142. segini melva2
  143. endif
  144. JELN=0
  145. DO 20 JEL=1,NBELEM
  146. DO 25 INOEU=1,NBNN
  147. IPT=IPT1.NUM(INOEU,JEL)
  148. IF (IVU(ICPR(IPT)).EQ.0) GOTO 30
  149. 25 CONTINUE
  150. if (isect.ne.0) goto 20
  151. JELN=JELN+1
  152. * write (6,*) ' mcham melva1 melva2 meleme ',mcham,melva1,melva2,
  153. * > meleme
  154. DO INOEU=1,NBNN
  155. IPT2.NUM(INOEU,JELN)=IPT1.NUM(INOEU,JEL)
  156. ENDDO
  157. if (mcham.ne.0) then
  158. DO INOEU=1,NBNN
  159. melva2.velche(INOEU,JELN)=
  160. $ melva1.velche(min(INOEU,lva1),JEL)
  161. ENDDO
  162. ENDIF
  163. IPT2.ICOLOR(JELN)=IPT1.ICOLOR(JEL)
  164. GOTO 20
  165. 30 CONTINUE
  166. VOLUM=KSURF(IPT1.ITYPEL).NE.IPT1.ITYPEL
  167. * IF (VOLUM) THEN
  168. IPT=IPT1.NUM(1,JEL)
  169. XGRAV=XCORD(1,ICPR(IPT))
  170. YGRAV=XCORD(2,ICPR(IPT))
  171. ZGRAV=XCORD(3,ICPR(IPT))
  172. IF (VCHCA.NE.0) VGRAV=VCHCA(IPT)
  173. if (mcham.ne.0) chgrav=melva1.velche(1,JEL)
  174. DO 21 INOEU=2,NBNN
  175. IPT=IPT1.NUM(INOEU,JEL)
  176. XGRAV=XGRAV+XCORD(1,ICPR(IPT))
  177. YGRAV=YGRAV+XCORD(2,ICPR(IPT))
  178. ZGRAV=ZGRAV+XCORD(3,ICPR(IPT))
  179. IF (VCHCA.NE.0) VGRAV=VGRAV+VCHCA(IPT)
  180. if (mcham.ne.0) chgrav=chgrav+
  181. $ melva1.velche(min(INOEU,lva1),JEL)
  182. 21 CONTINUE
  183. XGRAV=XGRAV/NBNN
  184. YGRAV=YGRAV/NBNN
  185. ZGRAV=ZGRAV/NBNN
  186. C ON PREND COMME POINT DU PLAN LA PROJECTION DU CENTRE GRAVITE
  187. SIGRAV=(XGRAV-XCT)*XN+(YGRAV-YCT)*YN+(ZGRAV-ZCT)*ZN
  188. XCT=XGRAV-SIGRAV*XN
  189. YCT=YGRAV-SIGRAV*YN
  190. ZCT=ZGRAV-SIGRAV*ZN
  191. SIGRAV=(XGRAV-XCT)*XN+(YGRAV-YCT)*YN+(ZGRAV-ZCT)*ZN
  192. IF (ABS(SIGRAV).LE.1D-30) SIGRAV=1D-30
  193. NJGRAV=0
  194. IF (VCHCA.NE.0) VGRAV=VGRAV/NBNN
  195. if (mcham.ne.0) CHGRAV=CHGRAV/NBNN
  196. * ENDIF
  197. C DECOMPOSITION EN FACE PUIS EN TRIANGLE
  198. NBFAC=LTEL(1,IPT1.ITYPEL)
  199. IAD=LTEL(2,IPT1.ITYPEL)-1
  200. IF (NBFAC.EQ.0) GOTO 20
  201. DO 161 IFAC=1,NBFAC
  202. ITYP=LDEL(1,IAD+IFAC)
  203. * SG Pour les TRI7/QUA9, il y a un traitement particulier pour ne pas
  204. * tracer les segments relies au noeud central. Il prend en compte le
  205. * fait que le decoupage est barycentrique
  206. lquaf=(ityp.eq.7.OR.ityp.eq.8)
  207. JAD=LDEL(2,IAD+IFAC)-1
  208. NPFAC=KDFAC(1,ITYP)
  209. IDEP=KDFAC(2,ITYP)
  210. IFEP=IDEP+3*(KDFAC(3,ITYP)-1)
  211. DO 160 ITRIAN=IDEP,IFEP,3
  212. kfa=kfac(itrian)
  213. kfb=kfac(itrian+1)
  214. kfc=kfac(itrian+2)
  215. JFA=JAD+KFAC(ITRIAN)
  216. JFB=JAD+KFAC(ITRIAN+1)
  217. JFC=JAD+KFAC(ITRIAN+2)
  218. ISEG(1)=0
  219. ISEG(2)=0
  220. ISEG(3)=0
  221. ISEG(4)=0
  222. ISEG1=0
  223. ISEG2=0
  224. ISEG3=0
  225. if (lquaf) then
  226. if (KFA.NE.NPFAC.AND.KFB.NE.NPFAC) ISEG1=1
  227. if (KFB.NE.NPFAC.AND.KFC.NE.NPFAC) ISEG2=1
  228. if (KFA.NE.NPFAC.AND.KFC.NE.NPFAC) ISEG3=1
  229. else
  230. IF (MOD(JFB-JFA+NPFAC,NPFAC).EQ.1) ISEG1=1
  231. IF (MOD(JFB-JFA+NPFAC,NPFAC).EQ.NPFAC-1) ISEG1=1
  232. IF (MOD(JFC-JFB+NPFAC,NPFAC).EQ.1) ISEG2=1
  233. IF (MOD(JFC-JFB+NPFAC,NPFAC).EQ.NPFAC-1) ISEG2=1
  234. IF (MOD(JFA-JFC+NPFAC,NPFAC).EQ.1) ISEG3=1
  235. IF (MOD(JFA-JFC+NPFAC,NPFAC).EQ.NPFAC-1) ISEG3=1
  236. endif
  237. IAFA=LFAC(JFA)
  238. IBFA=LFAC(JFB)
  239. ICFA=LFAC(JFC)
  240. IA=IPT1.NUM(IAFA,JEL)
  241. IB=IPT1.NUM(IBFA,JEL)
  242. IC=IPT1.NUM(ICFA,JEL)
  243. XA=XCORD(1,ICPR(IA))
  244. YA=XCORD(2,ICPR(IA))
  245. ZA=XCORD(3,ICPR(IA))
  246. XB=XCORD(1,ICPR(IB))
  247. YB=XCORD(2,ICPR(IB))
  248. ZB=XCORD(3,ICPR(IB))
  249. XC=XCORD(1,ICPR(IC))
  250. YC=XCORD(2,ICPR(IC))
  251. ZC=XCORD(3,ICPR(IC))
  252. C TESTONS SI LES POINTS SONT DU BON COTE
  253. SIGA=(XA-XCT)*XN+(YA-YCT)*YN+(ZA-ZCT)*ZN
  254. IF (ABS(SIGA).LE.1D-30) SIGA=1D-30
  255. SIGB=(XB-XCT)*XN+(YB-YCT)*YN+(ZB-ZCT)*ZN
  256. IF (ABS(SIGB).LE.1D-30) SIGB=1D-30
  257. SIGC=(XC-XCT)*XN+(YC-YCT)*YN+(ZC-ZCT)*ZN
  258. IF (ABS(SIGC).LE.1D-30) SIGC=1D-30
  259. if (isect.eq.1) goto 350
  260. IF (SIGA.GT.0..OR.SIGB.GT.0..OR.SIGC.GT.0.) GOTO 103
  261. IF (VOLUM) THEN
  262. IA1=MIN(IA,IB,IC)
  263. IB1=MAX(IA,IB,IC)
  264. IC1=IA+IB+IC
  265. DO 102 IDJF=ITRT(/1)-4,1,-5
  266. ITR1=MIN(ITRT(IDJF),ITRT(IDJF+1),ITRT(IDJF+2))
  267. ITR2=MAX(ITRT(IDJF),ITRT(IDJF+1),ITRT(IDJF+2))
  268. ITR3=ITRT(IDJF)+ITRT(IDJF+1)+ITRT(IDJF+2)
  269. IF (IA1.NE.ITR1) GOTO 102
  270. IF (IB1.NE.ITR2) GOTO 102
  271. IF (IC1.NE.ITR3) GOTO 102
  272. * WRITE (6,*) ' TRIANGLE EN DOUBLE CAS 1 ',IA,IB,IC
  273. C LE TRIANGLE EST DECLARE NON TRACABLE
  274. ITRT(IDJF+4)=MOD(ITRT(IDJF+4),16)+16
  275. GOTO 301
  276. 102 CONTINUE
  277. ENDIF
  278. * WRITE (6,*) ' NOUVEAU TRIANGLE ',IA,IB,IC
  279. ITRT(**)=IA
  280. ITRT(**)=IB
  281. ITRT(**)=IC
  282. ITRT(**)=IPT1.ICOLOR(JEL)
  283. ITRT(**)=ISEG1+2*ISEG2+4*ISEG3
  284. if (mcham.ne.0) then
  285. xtrt(**)=melva1.velche(min(lva1,iafa),jel)
  286. xtrt(**)=melva1.velche(min(lva1,ibfa),jel)
  287. xtrt(**)=melva1.velche(min(lva1,icfa),jel)
  288. endif
  289. 301 CONTINUE
  290. GOTO 101
  291. 103 CONTINUE
  292. IF (SIGA.GT.0..AND.SIGB.GT.0..AND.SIGC.GT.0.) GOTO 101
  293. IPOS=0
  294. IF (SIGA.LE.0.) THEN
  295. IPOS=IPOS+1
  296. JTT(IPOS)=IA
  297. ISEG(IPOS)=ISEG1
  298. if (mcham.ne.0) xsegm(ia)=
  299. > melva1.velche(min(lva1,iafa),jel)
  300. ENDIF
  301. IF (SIGA*SIGB.LT.0..AND.(.NOT.(SIGA.LE.0..AND.SIGB.LE.0.))) THEN
  302. IA1=MIN(IA,IB)
  303. IB1=MAX(IA,IB)
  304. DO 104 NSEGM=1,ISEGM(/1),3
  305. IF (IA1.NE.ISEGM(NSEGM)) GOTO 104
  306. IF (IB1.NE.ISEGM(NSEGM+1)) GOTO 104
  307. ISUP=ISEGM(NSEGM+2)
  308. if (mcham.ne.0)
  309. > xsegm(isup)=(melva1.velche(min(lva1,iafa),jel)*sigb-
  310. > melva1.velche(min(lva1,ibfa),jel)*siga)/(sigb-siga)
  311. * WRITE (6,*) ' POINT EN DOUBLE ',IA1,IB1,ISUP
  312. GOTO 105
  313. 104 CONTINUE
  314. ITE=ITE+1
  315. SEGADJ XCORD
  316. XCORD(1,ITE)=(XA*SIGB-XB*SIGA)/(SIGB-SIGA)
  317. XCORD(2,ITE)=(YA*SIGB-YB*SIGA)/(SIGB-SIGA)
  318. XCORD(3,ITE)=(ZA*SIGB-ZB*SIGA)/(SIGB-SIGA)
  319. IF (VCHCA.NE.0)
  320. # VCHCA(**)=(VCHCA(IA)*SIGB-VCHCA(IB)*SIGA)/(SIGB-SIGA)
  321. ICPR(**)=ITE
  322. ISUP=ICPR(/1)
  323. ISEGM(**)=IA1
  324. ISEGM(**)=IB1
  325. ISEGM(**)=ISUP
  326. if (mcham.ne.0)
  327. > xsegm(**)=(melva1.velche(min(lva1,iafa),jel)*sigb-
  328. > melva1.velche(min(lva1,ibfa),jel)*siga)/(sigb-siga)
  329. 105 CONTINUE
  330. IPOS=IPOS+1
  331. JTT(IPOS)=ISUP
  332. IF (SIGB.LE.0.) THEN
  333. ISEG(IPOS)=ISEG1
  334. ELSE
  335. ISEG(IPOS)=1
  336. ENDIF
  337. ENDIF
  338. IF (SIGB.LE.0.) THEN
  339. IPOS=IPOS+1
  340. JTT(IPOS)=IB
  341. ISEG(IPOS)=ISEG2
  342. if (mcham.ne.0) xsegm(ib)=
  343. > melva1.velche(min(lva1,ibfa),jel)
  344. ENDIF
  345. IF (SIGB*SIGC.LT.0..AND.(.NOT.(SIGB.LE.0..AND.SIGC.LE.0.))) THEN
  346. IB1=MIN(IB,IC)
  347. IC1=MAX(IB,IC)
  348. DO 106 NSEGM=1,ISEGM(/1),3
  349. IF (IB1.NE.ISEGM(NSEGM)) GOTO 106
  350. IF (IC1.NE.ISEGM(NSEGM+1)) GOTO 106
  351. ISUP=ISEGM(NSEGM+2)
  352. if (mcham.ne.0)
  353. > xsegm(isup)=(melva1.velche(min(lva1,ibfa),jel)*sigc-
  354. > melva1.velche(min(lva1,icfa),jel)*sigb)/(sigc-sigb)
  355. * WRITE (6,*) ' POINT EN DOUBLE ',IB1,IC1,ISUP
  356. GOTO 107
  357. 106 CONTINUE
  358. ITE=ITE+1
  359. SEGADJ XCORD
  360. XCORD(1,ITE)=(XB*SIGC-XC*SIGB)/(SIGC-SIGB)
  361. XCORD(2,ITE)=(YB*SIGC-YC*SIGB)/(SIGC-SIGB)
  362. XCORD(3,ITE)=(ZB*SIGC-ZC*SIGB)/(SIGC-SIGB)
  363. IF (VCHCA.NE.0)
  364. # VCHCA(**)=(VCHCA(IB)*SIGC-VCHCA(IC)*SIGB)/(SIGC-SIGB)
  365. ICPR(**)=ITE
  366. ISUP=ICPR(/1)
  367. ISEGM(**)=IB1
  368. ISEGM(**)=IC1
  369. ISEGM(**)=ISUP
  370. if (mcham.ne.0)
  371. > xsegm(**)=(melva1.velche(min(lva1,ibfa),jel)*sigc-
  372. > melva1.velche(min(lva1,icfa),jel)*sigb)/(sigc-sigb)
  373. 107 CONTINUE
  374. IPOS=IPOS+1
  375. JTT(IPOS)=ISUP
  376. IF (SIGC.LE.0.) THEN
  377. ISEG(IPOS)=ISEG2
  378. ELSE
  379. ISEG(IPOS)=1
  380. ENDIF
  381. ENDIF
  382. IF (SIGC.LE.0.) THEN
  383. IPOS=IPOS+1
  384. JTT(IPOS)=IC
  385. ISEG(IPOS)=ISEG3
  386. if (mcham.ne.0) xsegm(ic)=
  387. > melva1.velche(min(lva1,icfa),jel)
  388. ENDIF
  389. IF (SIGC*SIGA.LT.0..AND.(.NOT.(SIGC.LE.0..AND.SIGA.LE.0.))) THEN
  390. IC1=MIN(IC,IA)
  391. IA1=MAX(IC,IA)
  392. DO 108 NSEGM=1,ISEGM(/1),3
  393. IF (IC1.NE.ISEGM(NSEGM)) GOTO 108
  394. IF (IA1.NE.ISEGM(NSEGM+1)) GOTO 108
  395. ISUP=ISEGM(NSEGM+2)
  396. if (mcham.ne.0)
  397. > xsegm(isup)=(melva1.velche(min(lva1,icfa),jel)*siga-
  398. > melva1.velche(min(lva1,iafa),jel)*sigc)/(siga-sigc)
  399. * WRITE (6,*) ' POINT EN DOUBLE ',IC1,IA1,ISUP
  400. GOTO 109
  401. 108 CONTINUE
  402. ITE=ITE+1
  403. SEGADJ XCORD
  404. XCORD(1,ITE)=(XC*SIGA-XA*SIGC)/(SIGA-SIGC)
  405. XCORD(2,ITE)=(YC*SIGA-YA*SIGC)/(SIGA-SIGC)
  406. XCORD(3,ITE)=(ZC*SIGA-ZA*SIGC)/(SIGA-SIGC)
  407. IF (VCHCA.NE.0)
  408. # VCHCA(**)=(VCHCA(IC)*SIGA-VCHCA(IA)*SIGC)/(SIGA-SIGC)
  409. ICPR(**)=ITE
  410. ISUP=ICPR(/1)
  411. ISEGM(**)=IC1
  412. ISEGM(**)=IA1
  413. ISEGM(**)=ISUP
  414. if (mcham.ne.0)
  415. > xsegm(**)=(melva1.velche(min(lva1,icfa),jel)*siga-
  416. > melva1.velche(min(lva1,iafa),jel)*sigc)/(siga-sigc)
  417. 109 CONTINUE
  418. IPOS=IPOS+1
  419. JTT(IPOS)=ISUP
  420. IF (SIGA.LE.0.) THEN
  421. ISEG(IPOS)=ISEG3
  422. ELSE
  423. ISEG(IPOS)=1
  424. ENDIF
  425. ENDIF
  426. IF (IPOS.GT.4) WRITE (6,*) ' ANOMALIE IPOS SURFACE ',IPOS
  427. IF (IPOS.LT.3) WRITE (6,*) ' ANOMALIE IPOS SURFACE ',IPOS
  428. IF (IPOS.LT.3) GOTO 101
  429. IF (IPOS.EQ.3) THEN
  430. IF (VOLUM) THEN
  431. IA1=MIN(JTT(1),JTT(2),JTT(3))
  432. IB1=MAX(JTT(1),JTT(2),JTT(3))
  433. IC1=JTT(1)+JTT(2)+JTT(3)
  434. DO 110 IDJF=ITRT(/1)-4,1,-5
  435. ITR1=MIN(ITRT(IDJF),ITRT(IDJF+1),ITRT(IDJF+2))
  436. ITR2=MAX(ITRT(IDJF),ITRT(IDJF+1),ITRT(IDJF+2))
  437. ITR3=ITRT(IDJF)+ITRT(IDJF+1)+ITRT(IDJF+2)
  438. IF (IA1.NE.ITR1) GOTO 110
  439. IF (IB1.NE.ITR2) GOTO 110
  440. IF (IC1.NE.ITR3) GOTO 110
  441. * WRITE (6,*) ' TRIANGLE EN DOUBLE CAS 2 ',JTT(1),JTT(2),JTT(3)
  442. C LE TRIANGLE EST DECLARE NON TRACABLE
  443. ITRT(IDJF+4)=MOD(ITRT(IDJF+4),16)+16
  444. GOTO 303
  445. 110 CONTINUE
  446. ENDIF
  447. * WRITE (6,*) ' NOUVEAU TRIANGLE ',JTT(1),JTT(2),JTT(3)
  448. ITRT(**)=JTT(1)
  449. ITRT(**)=JTT(2)
  450. ITRT(**)=JTT(3)
  451. ITRT(**)=IPT1.ICOLOR(JEL)
  452. ITRT(**)=ISEG(1)+2*ISEG(2)+4*ISEG(3)
  453. if (mcham.ne.0) then
  454. xtrt(**)=xsegm(jtt(1))
  455. xtrt(**)=xsegm(jtt(2))
  456. xtrt(**)=xsegm(jtt(3))
  457. endif
  458. ENDIF
  459. 303 CONTINUE
  460. IF (IPOS.EQ.4) THEN
  461. IF (VOLUM) THEN
  462. IA1=MIN(JTT(1),JTT(2),JTT(3),JTT(4))
  463. IB1=MAX(JTT(1),JTT(2),JTT(3),JTT(4))
  464. IC1=JTT(1)+JTT(2)+JTT(3)+JTT(4)
  465. ID1=JTT(1)*JTT(2)*JTT(3)*JTT(4)
  466. DO 111 IDJF=IQUAT(/1)-5,1,-6
  467. ITR1=MIN(IQUAT(IDJF),IQUAT(IDJF+1),IQUAT(IDJF+2),IQUAT(IDJF+3))
  468. ITR2=MAX(IQUAT(IDJF),IQUAT(IDJF+1),IQUAT(IDJF+2),IQUAT(IDJF+3))
  469. ITR3=IQUAT(IDJF)+IQUAT(IDJF+1)+IQUAT(IDJF+2)+IQUAT(IDJF+3)
  470. ITR4=IQUAT(IDJF)*IQUAT(IDJF+1)*IQUAT(IDJF+2)*IQUAT(IDJF+3)
  471. IF (IA1.NE.ITR1) GOTO 111
  472. IF (IB1.NE.ITR2) GOTO 111
  473. IF (IC1.NE.ITR3) GOTO 111
  474. IF (ID1.NE.ITR4) GOTO 111
  475. * WRITE (6,*) ' QUADRILA EN DOUBLE ',JTT(1),JTT(2),JTT(3),JTT(4)
  476. C LE QUADRILATERE EST DECLARE NON TRACABLE
  477. IQUAT(IDJF+5)=MOD(IQUAT(IDJF+5),16)+16
  478. GOTO 302
  479. 111 CONTINUE
  480. ENDIF
  481. * WRITE (6,*) ' NOUVEAU QUADRILATERE ',JTT(1),JTT(2),JTT(3),JTT(4)
  482. IQUAT(**)=JTT(1)
  483. IQUAT(**)=JTT(2)
  484. IQUAT(**)=JTT(3)
  485. IQUAT(**)=JTT(4)
  486. IQUAT(**)=IPT1.ICOLOR(JEL)
  487. IQUAT(**)=ISEG(1)+2*ISEG(2)+4*ISEG(3)+8*ISEG(4)
  488. if (mcham.ne.0) then
  489. xquat(**)=xsegm(jtt(1))
  490. xquat(**)=xsegm(jtt(2))
  491. xquat(**)=xsegm(jtt(3))
  492. xquat(**)=xsegm(jtt(4))
  493. endif
  494. ENDIF
  495. 302 CONTINUE
  496. GOTO 101
  497. 101 CONTINUE
  498. 350 CONTINUE
  499. IF (.NOT.VOLUM) GOTO 160
  500. C ETUDE POUR LE CAS DES VOLUMES DU TETRAEDRE S'APPUYANT SUR LE
  501. C TRIANGLE ET LE CENTRE DE GRAVITE
  502. C TETRAEDRE
  503. IF (SIGA.LT.0..AND.SIGB.LT.0..AND.SIGC.LT.0..AND.SIGRAV
  504. # .LT.0.) GOTO 160
  505. IF (SIGA.GT.0..AND.SIGB.GT.0..AND.SIGC.GT.0..AND.SIGRAV
  506. # .GT.0.) GOTO 160
  507. IPOS=0
  508. ISEG(1)=0
  509. ISEG(2)=0
  510. ISEG(3)=0
  511. ISEG(4)=0
  512. IF (SIGRAV*SIGA.LE.0.) THEN
  513. IF (SIGA.EQ.0.) THEN
  514. ISUP=IA
  515. if (mcham.ne.0)
  516. > xsegm(isup)=melva1.velche(min(lva1,iafa),jel)
  517. GOTO 359
  518. ENDIF
  519. DO 358 NSEGM=1,NJGRAV
  520. IF (IA.NE.IJGRAV(1,NSEGM)) GOTO 358
  521. ISUP=IJGRAV(2,NSEGM)
  522. if (mcham.ne.0)
  523. > xsegm(isup)=(melva1.velche(min(lva1,iafa),jel)*sigrav-
  524. > chgrav*siga)/(sigrav-siga)
  525. GOTO 359
  526. 358 CONTINUE
  527. ITE=ITE+1
  528. SEGADJ XCORD
  529. XCORD(1,ITE)=(XA*SIGRAV-XGRAV*SIGA)/(SIGRAV-SIGA)
  530. XCORD(2,ITE)=(YA*SIGRAV-YGRAV*SIGA)/(SIGRAV-SIGA)
  531. XCORD(3,ITE)=(ZA*SIGRAV-ZGRAV*SIGA)/(SIGRAV-SIGA)
  532. IF (VCHCA.NE.0)
  533. # VCHCA(**)=(VCHCA(IA)*SIGRAV-VGRAV*SIGA)/(SIGRAV-SIGA)
  534. ICPR(**)=ITE
  535. ISUP=ICPR(/1)
  536. if (mcham.ne.0)
  537. > xsegm(**)=(melva1.velche(min(lva1,iafa),jel)*sigrav-
  538. > chgrav*siga)/(sigrav-siga)
  539. NJGRAV=NJGRAV+1
  540. IJGRAV(1,NJGRAV)=IA
  541. IJGRAV(2,NJGRAV)=ISUP
  542. 359 CONTINUE
  543. IPOS=IPOS+1
  544. JTT(IPOS)=ISUP
  545. ENDIF
  546. IF (SIGA*SIGB.LT.0..AND.
  547. # (.NOT.(SIGRAV*SIGA.LE.0..AND.SIGRAV*SIGB.LE.0.))) THEN
  548. IA1=MIN(IA,IB)
  549. IB1=MAX(IA,IB)
  550. DO 404 NSEGM=1,ISEGM(/1),3
  551. IF (IA1.NE.ISEGM(NSEGM)) GOTO 404
  552. IF (IB1.NE.ISEGM(NSEGM+1)) GOTO 404
  553. ISUP=ISEGM(NSEGM+2)
  554. * WRITE (6,*) ' POINT EN DOUBLE ',IA1,IB1,ISUP
  555. if (mcham.ne.0)
  556. > xsegm(isup)=(melva1.velche(min(lva1,iafa),jel)*sigb-
  557. > melva1.velche(min(lva1,ibfa),jel)*siga)/(sigb-siga)
  558. GOTO 405
  559. 404 CONTINUE
  560. ITE=ITE+1
  561. SEGADJ XCORD
  562. XCORD(1,ITE)=(XA*SIGB-XB*SIGA)/(SIGB-SIGA)
  563. XCORD(2,ITE)=(YA*SIGB-YB*SIGA)/(SIGB-SIGA)
  564. XCORD(3,ITE)=(ZA*SIGB-ZB*SIGA)/(SIGB-SIGA)
  565. IF (VCHCA.NE.0)
  566. # VCHCA(**)=(VCHCA(IA)*SIGB-VCHCA(IB)*SIGA)/(SIGB-SIGA)
  567. ICPR(**)=ITE
  568. ISUP=ICPR(/1)
  569. ISEGM(**)=IA1
  570. ISEGM(**)=IB1
  571. ISEGM(**)=ISUP
  572. if (mcham.ne.0)
  573. > xsegm(**)=(melva1.velche(min(lva1,iafa),jel)*sigb-
  574. > melva1.velche(min(lva1,ibfa),jel)*siga)/(sigb-siga)
  575. 405 CONTINUE
  576. IPOS=IPOS+1
  577. JTT(IPOS)=ISUP
  578. IF (SIGRAV*SIGB.GT.0.) THEN
  579. ISEG(IPOS)=1
  580. ENDIF
  581. ENDIF
  582. IF (SIGRAV*SIGB.LE.0.) THEN
  583. IF (SIGB.EQ.0.) THEN
  584. ISUP=IB
  585. if (mcham.ne.0)
  586. > xsegm(isup)=melva1.velche(min(lva1,ibfa),jel)
  587. GOTO 369
  588. ENDIF
  589. DO 368 NSEGM=1,NJGRAV
  590. IF (IB.NE.IJGRAV(1,NSEGM)) GOTO 368
  591. ISUP=IJGRAV(2,NSEGM)
  592. GOTO 369
  593. 368 CONTINUE
  594. ITE=ITE+1
  595. SEGADJ XCORD
  596. XCORD(1,ITE)=(XB*SIGRAV-XGRAV*SIGB)/(SIGRAV-SIGB)
  597. XCORD(2,ITE)=(YB*SIGRAV-YGRAV*SIGB)/(SIGRAV-SIGB)
  598. XCORD(3,ITE)=(ZB*SIGRAV-ZGRAV*SIGB)/(SIGRAV-SIGB)
  599. IF (VCHCA.NE.0)
  600. # VCHCA(**)=(VCHCA(IB)*SIGRAV-VGRAV*SIGB)/(SIGRAV-SIGB)
  601. ICPR(**)=ITE
  602. ISUP=ICPR(/1)
  603. if (mcham.ne.0)
  604. > xsegm(**)=(melva1.velche(min(lva1,ibfa),jel)*sigrav-
  605. > chgrav*sigb)/(sigrav-sigb)
  606. NJGRAV=NJGRAV+1
  607. IJGRAV(1,NJGRAV)=IB
  608. IJGRAV(2,NJGRAV)=ISUP
  609. 369 CONTINUE
  610. IPOS=IPOS+1
  611. JTT(IPOS)=ISUP
  612. if (mcham.ne.0)
  613. > xsegm(isup)=(melva1.velche(min(lva1,ibfa),jel)*sigrav-
  614. > chgrav*sigb)/(sigrav-sigb)
  615. ENDIF
  616. IF (SIGB*SIGC.LT.0..AND.
  617. # (.NOT.(SIGRAV*SIGB.LE.0..AND.SIGRAV*SIGC.LE.0.))) THEN
  618. IB1=MIN(IB,IC)
  619. IC1=MAX(IB,IC)
  620. DO 406 NSEGM=1,ISEGM(/1),3
  621. IF (IB1.NE.ISEGM(NSEGM)) GOTO 406
  622. IF (IC1.NE.ISEGM(NSEGM+1)) GOTO 406
  623. ISUP=ISEGM(NSEGM+2)
  624. * WRITE (6,*) ' POINT EN DOUBLE ',IB1,IC1,ISUP
  625. if (mcham.ne.0)
  626. > xsegm(isup)=(melva1.velche(min(lva1,ibfa),jel)*sigc-
  627. > melva1.velche(min(lva1,icfa),jel)*sigb)/(sigc-sigb)
  628. GOTO 407
  629. 406 CONTINUE
  630. ITE=ITE+1
  631. SEGADJ XCORD
  632. XCORD(1,ITE)=(XB*SIGC-XC*SIGB)/(SIGC-SIGB)
  633. XCORD(2,ITE)=(YB*SIGC-YC*SIGB)/(SIGC-SIGB)
  634. XCORD(3,ITE)=(ZB*SIGC-ZC*SIGB)/(SIGC-SIGB)
  635. IF (VCHCA.NE.0)
  636. # VCHCA(**)=(VCHCA(IB)*SIGC-VCHCA(IC)*SIGB)/(SIGC-SIGB)
  637. ICPR(**)=ITE
  638. ISUP=ICPR(/1)
  639. ISEGM(**)=IB1
  640. ISEGM(**)=IC1
  641. ISEGM(**)=ISUP
  642. if (mcham.ne.0)
  643. > xsegm(**)=(melva1.velche(min(lva1,ibfa),jel)*sigc-
  644. > melva1.velche(min(lva1,icfa),jel)*sigb)/(sigc-sigb)
  645. 407 CONTINUE
  646. IPOS=IPOS+1
  647. JTT(IPOS)=ISUP
  648. IF (SIGRAV*SIGC.GT.0.) THEN
  649. ISEG(IPOS)=1
  650. ENDIF
  651. ENDIF
  652. IF (SIGRAV*SIGC.LE.0.) THEN
  653. IF (SIGC.EQ.0.) THEN
  654. ISUP=IC
  655. if (mcham.ne.0)
  656. > xsegm(isup)=melva1.velche(min(lva1,icfa),jel)
  657. GOTO 379
  658. ENDIF
  659. DO 378 NSEGM=1,NJGRAV
  660. IF (IC.NE.IJGRAV(1,NSEGM)) GOTO 378
  661. ISUP=IJGRAV(2,NSEGM)
  662. if (mcham.ne.0)
  663. > xsegm(isup)=(melva1.velche(min(lva1,icfa),jel)*sigrav-
  664. > chgrav*sigc)/(sigrav-sigc)
  665. GOTO 379
  666. 378 CONTINUE
  667. ITE=ITE+1
  668. SEGADJ XCORD
  669. XCORD(1,ITE)=(XC*SIGRAV-XGRAV*SIGC)/(SIGRAV-SIGC)
  670. XCORD(2,ITE)=(YC*SIGRAV-YGRAV*SIGC)/(SIGRAV-SIGC)
  671. XCORD(3,ITE)=(ZC*SIGRAV-ZGRAV*SIGC)/(SIGRAV-SIGC)
  672. IF (VCHCA.NE.0)
  673. # VCHCA(**)=(VCHCA(IC)*SIGRAV-VGRAV*SIGC)/(SIGRAV-SIGC)
  674. ICPR(**)=ITE
  675. ISUP=ICPR(/1)
  676. if (mcham.ne.0)
  677. > xsegm(**)=(melva1.velche(min(lva1,icfa),jel)*sigrav-
  678. > chgrav*sigc)/(sigrav-sigc)
  679. NJGRAV=NJGRAV+1
  680. IJGRAV(1,NJGRAV)=IC
  681. IJGRAV(2,NJGRAV)=ISUP
  682. 379 CONTINUE
  683. IPOS=IPOS+1
  684. JTT(IPOS)=ISUP
  685. ENDIF
  686. IF (SIGC*SIGA.LT.0..AND.
  687. # (.NOT.(SIGRAV*SIGC.LE.0..AND.SIGRAV*SIGA.LE.0.))) THEN
  688. IC1=MIN(IC,IA)
  689. IA1=MAX(IC,IA)
  690. DO 408 NSEGM=1,ISEGM(/1),3
  691. IF (IC1.NE.ISEGM(NSEGM)) GOTO 408
  692. IF (IA1.NE.ISEGM(NSEGM+1)) GOTO 408
  693. ISUP=ISEGM(NSEGM+2)
  694. * WRITE (6,*) ' POINT EN DOUBLE ',IC1,IA1,ISUP
  695. if (mcham.ne.0)
  696. > xsegm(isup)=(melva1.velche(min(lva1,icfa),jel)*siga-
  697. > melva1.velche(min(lva1,iafa),jel)*sigc)/(siga-sigc)
  698. GOTO 409
  699. 408 CONTINUE
  700. ITE=ITE+1
  701. SEGADJ XCORD
  702. XCORD(1,ITE)=(XC*SIGA-XA*SIGC)/(SIGA-SIGC)
  703. XCORD(2,ITE)=(YC*SIGA-YA*SIGC)/(SIGA-SIGC)
  704. XCORD(3,ITE)=(ZC*SIGA-ZA*SIGC)/(SIGA-SIGC)
  705. IF (VCHCA.NE.0)
  706. # VCHCA(**)=(VCHCA(IC)*SIGA-VCHCA(IA)*SIGC)/(SIGA-SIGC)
  707. ICPR(**)=ITE
  708. ISUP=ICPR(/1)
  709. ISEGM(**)=IC1
  710. ISEGM(**)=IA1
  711. ISEGM(**)=ISUP
  712. if (mcham.ne.0)
  713. > xsegm(**)=(melva1.velche(min(lva1,icfa),jel)*siga-
  714. > melva1.velche(min(lva1,iafa),jel)*sigc)/(siga-sigc)
  715. 409 CONTINUE
  716. IPOS=IPOS+1
  717. JTT(IPOS)=ISUP
  718. IF (SIGRAV*SIGA.GT.0.) THEN
  719. ISEG(IPOS)=1
  720. ENDIF
  721. ENDIF
  722. IF (IPOS.GT.4) WRITE (6,*) ' ANOMALIE IPOS VOLUME ',IPOS
  723. IF (IPOS.LT.3) WRITE (6,*) ' ANOMALIE IPOS VOLUME ',IPOS
  724. IF (IPOS.LT.3) GOTO 160
  725. ITR(**)=JTT(1)
  726. ITR(**)=JTT(2)
  727. ITR(**)=JTT(3)
  728. ITR(**)=IPT1.ICOLOR(JEL)
  729. if (mcham.ne.0) then
  730. xtr(**)=xsegm(jtt(1))
  731. xtr(**)=xsegm(jtt(2))
  732. xtr(**)=xsegm(jtt(3))
  733. endif
  734. * WRITE (6,*) ' TRIANGLE (CAS 1) DU PLAN DE COUPE '
  735. * WRITE (6,*) JTT(1),JTT(2),JTT(3)
  736. C TRIANGLE DU PLAN DE COUPE
  737. IF (IPOS.EQ.3) THEN
  738. MCOUP(**)=ISEG(1)+2*ISEG(2)+4*ISEG(3)+8
  739. ELSE
  740. MCOUP(**)=ISEG(1)+2*ISEG(2)+4*0 +8
  741. ENDIF
  742. 403 CONTINUE
  743. IF (IPOS.GE.4) THEN
  744. ITR(**)=JTT(1)
  745. ITR(**)=JTT(3)
  746. ITR(**)=JTT(4)
  747. ITR(**)=IPT1.ICOLOR(JEL)
  748. if (mcham.ne.0) then
  749. xtr(**)=xsegm(jtt(1))
  750. xtr(**)=xsegm(jtt(3))
  751. xtr(**)=xsegm(jtt(4))
  752. endif
  753. * WRITE (6,*) ' TRIANGLE (CAS 2) DU PLAN DE COUPE '
  754. * WRITE (6,*) JTT(1),JTT(3),JTT(4)
  755. C TRIANGLE DU PLAN DE COUPE
  756. MCOUP(**)=0 +2*ISEG(3)+4*ISEG(4)+8
  757. ENDIF
  758. 402 CONTINUE
  759. 160 CONTINUE
  760. 161 CONTINUE
  761. 20 CONTINUE
  762. NBELEM=JELN
  763. SEGADJ IPT2
  764. ISU=ISU+1
  765. IPT8.LISOUS(ISU)=IPT2
  766. if (mcham.ne.0) then
  767. n1el=nbelem
  768. segadj melva2
  769. ipt8.lisref(isu)=melva2
  770. endif
  771. SEGDES IPT1
  772. 10 CONTINUE
  773. IF (NBSOU.NE.0) SEGDES MELEME
  774. 12 CONTINUE
  775. NBSOUS=ISU+1
  776. * IF (ITR(/1).EQ.0) NBSOUS=ISU
  777. NBELEM=0
  778. NBNN=0
  779. NBREF=0
  780. if (mcham.ne.0) nbref=nbsous
  781. SEGADJ IPT8
  782. MELEME=IPT8
  783. * IF (ITR(/1).EQ.0) RETURN
  784. * WRITE(6,*) ' NOMBRE DE TRIANGLE ENGENDREES DANS LE PLAN DE COUPE',
  785. * $ ITR(/1)/4
  786. * WRITE(6,*) ' NOMBRE DE TRIANGLE ENGENDREES HORS LE PLAN DE COUPE',
  787. * $ ITRT(/1)/5
  788. * WRITE(6,*) ' NOMBRE DE QUADRILA ENGENDREES HORS LE PLAN DE COUPE',
  789. * $ IQUAT(/1)/6
  790. NBELEM=ITR(/1)/4+ITRT(/1)/5+(IQUAT(/1)/6)*2
  791. NBNN=3
  792. NBREF=0
  793. NBSOUS=0
  794. SEGINI IPT4
  795. IPT4.ITYPEL=4
  796. if (mcham.ne.0) then
  797. n1el=nbelem
  798. n1ptel=nbnn
  799. segini melva4
  800. endif
  801. ITRL1=ITR(/1)/4
  802. DO 200 IEL=1,ITRL1
  803. DO NBNN=1,3
  804. IPT4.NUM(NBNN,IEL)=ITR((IEL-1)*4+NBNN)
  805. ENDDO
  806. if (mcham.ne.0) then
  807. DO NBNN=1,3
  808. melva4.velche(nbnn,iel)=xtr((IEL-1)*3+nbnn)
  809. ENDDO
  810. ENDIF
  811. IPT4.ICOLOR(IEL)=ITR(IEL*4)
  812. 200 CONTINUE
  813. ITRL2=ITRT(/1)/5
  814. DO 202 IEL=1,ITRL2
  815. DO 203 NBNN=1,3
  816. IPT4.NUM(NBNN,IEL+ITRL1)=ITRT((IEL-1)*5+NBNN)
  817. if (mcham.ne.0)
  818. > melva4.velche(nbnn,iel+itrl1)=xtrt((IEL-1)*3+nbnn)
  819. 203 CONTINUE
  820. IPT4.ICOLOR(IEL+ITRL1)=ITRT(IEL*5-1)
  821. MCOUP(**)=ITRT(IEL*5)
  822. 202 CONTINUE
  823. ITRL3=(IQUAT(/1)/6)
  824. DO 204 IEL=1,ITRL3
  825. IEL1=2*IEL-1
  826. DO 205 NBNN=1,3
  827. IPT4.NUM(NBNN,IEL1+ITRL1+ITRL2)=IQUAT((IEL-1)*6+NBNN)
  828. if (mcham.ne.0)
  829. > melva4.velche(nbnn,iel1+itrl1+itrl2)=xquat((IEL-1)*4
  830. $ +nbnn)
  831. 205 CONTINUE
  832. IPT4.ICOLOR(IEL1+ITRL1+ITRL2)=IQUAT(IEL*6-1)
  833. MCOUP(**)=MOD(IQUAT(IEL*6),4)+16*(IQUAT(IEL*6)/16)
  834. IEL2=2*IEL
  835. IPT4.NUM(1,IEL2+ITRL1+ITRL2)=IQUAT((IEL-1)*6+1)
  836. IPT4.NUM(2,IEL2+ITRL1+ITRL2)=IQUAT((IEL-1)*6+3)
  837. IPT4.NUM(3,IEL2+ITRL1+ITRL2)=IQUAT((IEL-1)*6+4)
  838. IPT4.ICOLOR(IEL2+ITRL1+ITRL2)=IQUAT(IEL*6-1)
  839. MCOUP(**)=0+MOD(IQUAT(IEL*6)/4,2)*2+MOD(IQUAT(IEL*6)/8,2)*4
  840. $ +16*(IQUAT(IEL*6)/16)
  841. if (mcham.ne.0) then
  842. melva4.velche(1,iel2+itrl1+itrl2)=xquat((IEL-1)*4+1)
  843. melva4.velche(2,iel2+itrl1+itrl2)=xquat((IEL-1)*4+3)
  844. melva4.velche(3,iel2+itrl1+itrl2)=xquat((IEL-1)*4+4)
  845. endif
  846. 204 CONTINUE
  847. * WRITE (6,*) ' LISTE DES ELEMENTS RAJOUTES '
  848. * DO 9834 J=1,NBELEM
  849. * WRITE (6,*) (IPT4.NUM(I,J),I=1,3)
  850. *9834 CONTINUE
  851. LISOUS(ISU+1)=IPT4
  852. if (mcham.ne.0) lisref(ISU+1)=melva4
  853. IF (MELEM2.NE.0) THEN
  854. IF (MEDSAU.EQ.0) THEN
  855. C ON COUPE MELEM2
  856. mcham=0
  857. MEDSAU=MELEME
  858. MEDCOU=MCOUP
  859. MELEME=MELEM2
  860. SEGSUP ITR,ITRT,IQUAT
  861. SEGINI MCOUP,ITR,ITRT,IQUAT
  862. GOTO 5000
  863. ELSE
  864. MELEM2=MELEME
  865. MELEME=MEDSAU
  866. MCOU2=MCOUP
  867. MCOUP=MEDCOU
  868. ENDIF
  869. ENDIF
  870. SEGSUP ITR,ISEGM,IJGRAV,ITRT,IQUAT
  871. if (mchamor.ne.0) segsup xtr,xtrt,xquat,xsegm
  872. *dbg write(ioimp,*) 'sortie crcou2'
  873. RETURN
  874. END
  875.  
  876.  
  877.  
  878.  
  879.  
  880.  
  881.  
  882.  
  883.  
  884.  
  885.  
  886.  
  887.  
  888.  
  889.  
  890.  
  891.  

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