Télécharger crcou2.eso

Retour à la liste

Numérotation des lignes :

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

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