Télécharger j3fafa.eso

Retour à la liste

Numérotation des lignes :

  1. C J3FAFA SOURCE CHAT 05/01/13 00:46:41 5004
  2. SUBROUTINE J3FAFA(WWORK1,WWORK2,TOL,IRET,ICAS,VWORK1,VWORK2)
  3. C----------------------------------------------------
  4. C TRAITEMENANT DU FACE A FACE (2D)
  5. C
  6. C VWORK1: NOUVELLES FACES DEJA TRAITEES
  7. C VWORK2: NOUVELLES FACES A TRAITEES
  8. C
  9. C CODE IST(1,I): 0 point non traite
  10. C 1 est sur le segment IST(2,I)
  11. C 2 est sur les segments IST(2,I) et IST(3,I)
  12. C -1 est a l'interieur
  13. C -2 est a l'exterieur
  14. C
  15. C CODE CRO(J,I): 1 cote sur le segment
  16. C -1 cote interieur
  17. C -2 cote exterieur
  18. C
  19. C PP 6/97
  20. C Pierre Pegon/JRC Ispra
  21. C----------------------------------------------------
  22. C
  23. IMPLICIT INTEGER(I-N)
  24. IMPLICIT REAL*8(A-H,O-Z)
  25. -INC CCOPTIO
  26. SEGMENT VWORK
  27. INTEGER FWWORK(NFACE)
  28. ENDSEGMENT
  29. POINTEUR VWORK1.VWORK,VWORK2.VWORK,VWDUMM.VWORK
  30. C
  31. SEGMENT WWORK
  32. REAL*8 PORIG(3),VNORM(3),VI(3),VJ(3)
  33. INTEGER FWORK
  34. INTEGER TWORK(NTROU)
  35. ENDSEGMENT
  36. POINTEUR WWORK1.WWORK,WWORK2.WWORK
  37. C
  38. SEGMENT WORK
  39. REAL*8 XYC(2,NPTO)
  40. INTEGER IST(3,NPTO)
  41. REAL*8 DENS(NPTO)
  42. INTEGER JUN
  43. ENDSEGMENT
  44. POINTEUR WORK1.WORK,WORK2.WORK,WORK3.WORK
  45. C
  46. SEGMENT JUNC
  47. INTEGER CRO(2,NPTO)
  48. ENDSEGMENT
  49. C
  50. LOGICAL LAINB,LAOUB,LAONB,LACUB,LBINA,LBOUA,LBONA
  51. LOGICAL LCAINB,LCAOUB,LCAONB,LCBINA,LCBOUA,LCBONA
  52. LOGICAL LPLAN
  53. C
  54. IF (IIMPI.EQ.1789)THEN
  55. WRITE(IOIMP,*)'>>> On entre dans j3fafa <<<'
  56. ENDIF
  57. C
  58. VWORK1=0
  59. VWORK2=0
  60. IRET=0
  61. C
  62. C ON REGARDE SI LES FACES SONT DANS LE MEME PLAN
  63. C SI OUI, ON ALIGNE LES POINTS
  64. C SI NON, ON SORT AVEC UN CAS 1
  65. C
  66. CALL J3COPL(WWORK1,WWORK2,LPLAN,TOL)
  67. IF (.NOT.LPLAN)THEN
  68. ICAS=1
  69. IF (IIMPI.EQ.1789)THEN
  70. WRITE(IOIMP,*)' >>> traitement de 2 faces non coplanaires <<<'
  71. ENDIF
  72. RETURN
  73. ENDIF
  74. IF (IIMPI.EQ.1789)THEN
  75. WRITE(IOIMP,*)' >>> face A <<<'
  76. CALL J3LIWW(WWORK1)
  77. WRITE(IOIMP,*)' >>> face B <<<'
  78. CALL J3LIWW(WWORK2)
  79. ENDIF
  80. C
  81. C ON COMMENCE PAR TRAITER LES CONTOURS EXTERIEURS
  82. C
  83. WORK1=WWORK1.FWORK
  84. WORK2=WWORK2.FWORK
  85. CALL J3COTO(WORK2,WORK1,TOL,IRET)
  86. IF (IRET.GT.0)THEN
  87. RETURN
  88. ENDIF
  89. CALL J3COTO(WORK1,WORK2,TOL,IRET)
  90. IF (IRET.GT.0)THEN
  91. RETURN
  92. ENDIF
  93. C
  94. C ON REGARDE SI 1 POINT DE A EST STRICTEMENT DANS B OU HORS DE B
  95. C OU SUR B
  96. C
  97. NPTO1=WORK1.XYC(/2)
  98. CALL J3TES1(WORK1.IST,NPTO1,LAINB,LAOUB,LAONB,NAONB)
  99. C
  100. C ON REGARDE SI 1 POINT DE B EST STRICTEMENT DANS A OU HORS DE A
  101. C OU SUR A
  102. C
  103. NPTO2=WORK2.XYC(/2)
  104. CALL J3TES1(WORK2.IST,NPTO2,LBINA,LBOUA,LBONA,NBONA)
  105. C
  106. C ON S'OCCUPE TOUT D'ABORD DU CAS OU A ET B SONT COMPLETEMENT DISJOINTS
  107. C ==> ON ELIMINE LA SEULE POSSIBILITE DE CAS 3 STRICT ET UNE DE CAS 1 ET 2
  108. C
  109. LACUB=.FALSE.
  110. IF(LAOUB.AND.(.NOT.LAONB))THEN
  111. IF(LAINB)THEN
  112. IRAISO=1
  113. GOTO 9999
  114. ENDIF
  115. IF(LBINA)THEN
  116. IF(LBOUA)THEN
  117. IRAISO=2
  118. GOTO 9999
  119. ENDIF
  120. GOTO 3
  121. ELSE
  122. IF(.NOT.LBOUA)THEN
  123. IRAISO=3
  124. GOTO 9999
  125. ENDIF
  126. GOTO 1
  127. ENDIF
  128. ENDIF
  129. C
  130. IF((.NOT.LAOUB).AND.(.NOT.LAONB))THEN
  131. IF((.NOT.LAINB).OR.(.NOT.LBOUA))THEN
  132. IRAISO=4
  133. GOTO 9999
  134. ENDIF
  135. GOTO 2
  136. ENDIF
  137. C
  138. C POUR CONTINUER IL FAUT SAVOIR VRAIMENT SI ON COUPE
  139. C
  140. CALL J3JUNC(WORK1,WORK2,TOL,IRET)
  141. IF (IRET.GT.0)THEN
  142. RETURN
  143. ENDIF
  144. JUNC=WORK1.JUN
  145. CALL J3TES2(CRO,NPTO1,LCAINB,LCAOUB,LCAONB)
  146. LACUB=LCAINB.AND.LCAOUB
  147. C
  148. C ET SI ON RECOUPE!
  149. C
  150. CALL J3JUNC(WORK2,WORK1,TOL,IRET)
  151. IF (IRET.GT.0)THEN
  152. RETURN
  153. ENDIF
  154. JUNC=WORK2.JUN
  155. CALL J3TES2(CRO,NPTO2,LCBINA,LCBOUA,LCBONA)
  156. C
  157. C ON FINIT LE CAS 1
  158. C
  159. IF((.NOT.LCAINB).AND.(.NOT.LCBINA).AND.LCAOUB.AND.LCBOUA)GOTO 1
  160. C
  161. C ON FINIT LE CAS 2
  162. C
  163. IF(.NOT.LCAOUB) GOTO 2
  164. C
  165. C ON S'OCCUPE DU CAS 4
  166. C
  167. IF(LACUB)GOTO 4
  168. C
  169. C ON S'OCCUPE DU 4 "TANGENT" ET DU "FAUX" 3
  170. C
  171. IF((.NOT.LCAINB).AND.(.NOT.LCBOUA).AND.LAONB)THEN
  172. IF(NAONB.EQ.1)THEN
  173. GOTO 3
  174. ELSE
  175. GOTO 4
  176. ENDIF
  177. ENDIF
  178. C
  179.  
  180. IRAISO=5
  181. GOTO 9999
  182. C
  183. C CAS NO. 1: ON NE FAIT RIEN
  184. C
  185. 1 ICAS=1
  186. C
  187. IF (IIMPI.EQ.1789)THEN
  188. WRITE(IOIMP,*)' >>> traitement d"un cas no.1 <<<'
  189. ENDIF
  190. C
  191. RETURN
  192. C
  193. C CAS NO. 2: ON CONTROLE LES TROUS
  194. C
  195. 2 ICAS=2
  196. C
  197. IF (IIMPI.EQ.1789)THEN
  198. WRITE(IOIMP,*)' >>> traitement d"un cas no.2 <<<'
  199. ENDIF
  200. C
  201. NTROU1=WWORK1.TWORK(/1)
  202. NTROU2=WWORK2.TWORK(/1)
  203. IF(NTROU1.NE.0)THEN
  204. WRITE(IOIMP,*)'CAS 2: face A avec trrrou'
  205. IRAISO=21
  206. GOTO 9999
  207. ENDIF
  208. C
  209. C SI PAS DE TROU DANS B... ON VERIFIE SI A N'EST PAS EGAL A B
  210. C ET SI OUI ON LE REND IDENTIQUE
  211. C
  212. IF(NTROU2.EQ.0)THEN
  213. IF(NTROU1.EQ.0)THEN
  214. CALL J3IDEN(WORK1,WORK2,TOL)
  215. WWORK1.FWORK=WORK1
  216. RETURN
  217. ELSE
  218. IRAISO=22
  219. GOTO 9999
  220. ENDIF
  221. C
  222. C ... SINON ON REMPLACE B PAR LES TROUS DE B
  223. C
  224. ELSE
  225. DO 20 IE1=1,NTROU2
  226. WORK2=WWORK2.TWORK(IE1)
  227. CALL J3COTO(WORK2,WORK1,TOL,IRET)
  228. IF (IRET.GT.0)THEN
  229. RETURN
  230. ENDIF
  231. CALL J3COTO(WORK1,WORK2,TOL,IRET)
  232. IF (IRET.GT.0)THEN
  233. RETURN
  234. ENDIF
  235. C
  236. C 2 SEULS CAS A VERIFIER: CAS 1 DISJOINT (A SANS TROU)
  237. C CAS 2
  238. C SINON ERREUR
  239. C
  240. NPTO1=WORK1.XYC(/2)
  241. CALL J3TES1(WORK1.IST,NPTO1,LAINB,LAOUB,LAONB,NAONB)
  242. C
  243. NPTO2=WORK2.XYC(/2)
  244. CALL J3TES1(WORK2.IST,NPTO2,LBINA,LBOUA,LBONA,NBONA)
  245. C
  246. IF(LAOUB.AND.(.NOT.LAONB))THEN
  247. IF(LAINB.OR.LBINA.OR.(.NOT.LBOUA).OR.(NTROU1.NE.0))THEN
  248. IRAISO=23
  249. GOTO 9999
  250. ENDIF
  251. GOTO 20
  252. ENDIF
  253. C
  254. IF((.NOT.LAOUB).AND.(.NOT.LAONB))GOTO 20
  255. C
  256. CALL J3JUNC(WORK1,WORK2,TOL,IRET)
  257. IF (IRET.GT.0)THEN
  258. RETURN
  259. ENDIF
  260. JUNC=WORK1.JUN
  261. CALL J3TES2(CRO,NPTO1,LCAINB,LCAOUB,LCAONB)
  262. LACUB=LCAINB.AND.LCAOUB
  263. IF(.NOT.LCAOUB) GOTO 20
  264. IRAISO=24
  265. GOTO 9999
  266. 20 CONTINUE
  267. ENDIF
  268. C
  269. RETURN
  270. C
  271. C CAS NO. 3: D'ABORD ON VERIFIE QUE B N'A PAS DE TROU
  272. C
  273. 3 ICAS=3
  274. C
  275. IF (IIMPI.EQ.1789)THEN
  276. WRITE(IOIMP,*)' >>> traitement d"un cas no.3 <<<'
  277. ENDIF
  278. C
  279. NTROU2=WWORK2.TWORK(/1)
  280. IF(NTROU2.NE.0)THEN
  281. IRAISO=31
  282. GOTO 9999
  283. ENDIF
  284. C
  285. C ON CREE UNE NOUVELLE FACE (RECOPIE DE WORK2)
  286. C
  287. NFACE=1
  288. SEGINI,VWORK1
  289. SEGINI,WWORK=WWORK2
  290. VWORK1.FWWORK(1)=WWORK
  291. SEGINI,WORK=WORK2
  292. JUN=0
  293. FWORK=WORK
  294. C
  295. C ON AJOUTE ENSUITE UN TROU A A QUE L'ON MET EN PREMIERE
  296. C POSITION (ON INVERSE LA NUMEROTATION DE B)
  297. C
  298. NTROU1=WWORK1.TWORK(/1)+1
  299. NTROU=NTROU1
  300. SEGADJ,WWORK1
  301. IF (NTROU1.GT.1)THEN
  302. DO IE1=NTROU1,2,-1
  303. WWORK1.TWORK(IE1)=WWORK1.TWORK(IE1-1)
  304. ENDDO
  305. ENDIF
  306. C
  307. SEGINI,WORK1=WORK2
  308. WORK1.JUN=0
  309. NPTO1=NPTO2
  310. CALL J3ORIE(1,WORK1.XYC,WORK1.DENS,NPTO1,-1,TOL,IRET)
  311. IF(IRET.NE.0)THEN
  312. IRAISO=32
  313. GOTO 9999
  314. ENDIF
  315. WWORK1.TWORK(1)=WORK1
  316. C
  317. C SI UN SEUL TROU ON SORT
  318. C
  319. IF(NTROU1.EQ.1)RETURN
  320. C
  321. C ON VERIFIE QUE CE NOUVEAU TROU EST UN CAS 1 VIS A VIS DES
  322. C AUTRES TROUS DE A (ATTENTION, ON COMPTE LE NB DE CAS AVEC
  323. C CONTACT EN 1 SEUL POINT)
  324. C
  325. DO 30 IE1=2,NTROU1
  326. WORK2=WWORK1.TWORK(IE1)
  327. IF(WORK2.EQ.0)GOTO 30
  328. CALL J3COTO(WORK2,WORK1,TOL,IRET)
  329. IF (IRET.GT.0)THEN
  330. RETURN
  331. ENDIF
  332. CALL J3COTO(WORK1,WORK2,TOL,IRET)
  333. IF (IRET.GT.0)THEN
  334. RETURN
  335. ENDIF
  336. C
  337. NPTO1=WORK1.XYC(/2)
  338. CALL J3TES1(WORK1.IST,NPTO1,LAINB,LAOUB,LAONB,NAONB)
  339. C
  340. NPTO2=WORK2.XYC(/2)
  341. CALL J3TES1(WORK2.IST,NPTO2,LBINA,LBOUA,LBONA,NBONA)
  342. C
  343. C A-T-ON UN CAS 1 DISJOINT? (SI OUI ON PASSE AU TROU SUIVANT)
  344. C
  345. IF(LAOUB.AND.(.NOT.LAONB))THEN
  346. IF(LAINB.OR.LBINA.OR.(.NOT.LBOUA))THEN
  347. IRAISO=33
  348. GOTO 9999
  349. ENDIF
  350. GOTO 30
  351. ENDIF
  352. C
  353. C A-T-ON UN CAS 1 AVEC CONTACT ? (SI OUI ON COALESCE)
  354. C (ATTENTION, ON EXCLUT LE CONTACT PONCTUEL EN 1 SEUL POINT))
  355. C WARNING UN CAS 2 SEMBLE LICITE!!!!!!!!
  356. C
  357. IF((.NOT.LAOUB).AND.(.NOT.LAONB))THEN
  358. IF((.NOT.LAINB).OR.(.NOT.LBOUA))THEN
  359. IRAISO=34
  360. GOTO 9999
  361. ENDIF
  362. SEGSUP,WORK,WWORK,VWORK1,WORK1
  363. WWORK1.TWORK(1)=0
  364. ICAS=1
  365. GOTO 31
  366. ENDIF
  367. C
  368. CALL J3JUNC(WORK1,WORK2,TOL,IRET)
  369. IF (IRET.GT.0)THEN
  370. RETURN
  371. ENDIF
  372. JUNC=WORK1.JUN
  373. NPTO1=WORK1.XYC(/2)
  374. CALL J3TES2(CRO,NPTO1,LCAINB,LCAOUB,LCAONB)
  375. LACUB=LCAINB.AND.LCAOUB
  376. C
  377. CALL J3JUNC(WORK2,WORK1,TOL,IRET)
  378. IF (IRET.GT.0)THEN
  379. RETURN
  380. ENDIF
  381. NPTO2=WORK2.XYC(/2)
  382. JUNC=WORK2.JUN
  383. CALL J3TES2(CRO,NPTO2,LCBINA,LCBOUA,LCBONA)
  384. C
  385. IF((.NOT.LCAINB).AND.(.NOT.LCBINA).AND.LCAOUB.AND.LCBOUA)THEN
  386. IF(NAONB.EQ.1)GOTO 30
  387. CALL J3COAL(WORK1,WORK2,LCAONB,VWORK,NFACEA,TOL,IRET)
  388. IF(IRET.GT.0)THEN
  389. RETURN
  390. ELSE
  391. JUNC=WORK2.JUN
  392. IF(JUNC.NE.0)SEGSUP,JUNC
  393. SEGSUP,WORK2
  394. WWORK1.TWORK(1)=WORK1
  395. WWORK1.TWORK(IE1)=0
  396. ENDIF
  397. C
  398. C ATTENTION UNE DES NFACEA FACES EVENTUELLEMENT CREES PEUT
  399. C CONTENIR STRICTEMENT UN DES TROU DE A QUI DEVIENT UN TROU DE LA
  400. C NOUVELLE FACE
  401. C
  402. IF(NFACEA.GT.0)THEN
  403. CALL J3HEAD(WWORK1,VWORK)
  404. CALL J3COAK(WWORK1,VWORK,TOL,IRET)
  405. CALL J3VPLU(VWORK2,VWORK)
  406. ENDIF
  407. ELSE
  408. C
  409. C ON EJECTE UN CAS 2 AVEC CONTACT QUI EST LICITE
  410. C
  411. IF (.NOT.LCAOUB)THEN
  412. SEGSUP,WORK,WWORK,VWORK1,WORK1
  413. WWORK1.TWORK(1)=0
  414. ICAS=1
  415. GOTO 31
  416. ENDIF
  417. IRAISO=35
  418. GOTO 9999
  419. ENDIF
  420. 30 CONTINUE
  421. C
  422. C ON REDUIT LE TWORK DE A DU NOMBRE DE COALESCENCE
  423. C
  424. 31 CALL J3REDU(WWORK1)
  425. C
  426. C
  427. RETURN
  428. C
  429. C CAS NO. 4: ON CONTROLE LES TROU DE B
  430. C
  431. 4 ICAS=4
  432. C
  433. IF (IIMPI.EQ.1789)THEN
  434. WRITE(IOIMP,*)' >>> traitement d"un cas no.4 <<<'
  435. ENDIF
  436. C
  437. NTROU2=WWORK2.TWORK(/1)
  438. IF(NTROU2.NE.0)THEN
  439. IRAISO=41
  440. GOTO 9999
  441. ENDIF
  442. C
  443. C ON COUPE A PAR B ET ON GARDE LA PARTIE INTERIEURE (SANS
  444. C REDISTRIBUTION DES TROU) DANS VWORK1.
  445. C
  446. CALL J3COUP(WWORK1,WORK2,VWORK1,VWORK,0,TOL,IRET)
  447. IF (IRET.GT.0)THEN
  448. IRAISO=42
  449. GOTO 9999
  450. ENDIF
  451. CALL J3HEAD(WWORK1,VWORK1)
  452. C
  453. C S'IL N'Y A PAS DE TROU DANS A ON SAUTE DIRECTEMENT
  454. C APRES LA PHASE DE SECONDE COUPE
  455. C
  456. NTROU1=WWORK1.TWORK(/1)
  457. IF(NTROU1.EQ.0)GOTO 45
  458. CALL J3DET1(VWORK)
  459. C
  460. C S'IL Y A DES TROU DANS A, ILS DOIVENT ETRE DES CAS 1 VIS A VIS
  461. C DE B ET EVENTUELLEMENT COHALESCER AVEC B ET DONC ON COMMENCE PAR
  462. C INVERSER B DANS WORK1, ENSUITE ON CONTINUE COMME DANS CAS 3
  463. C
  464. SEGINI,WORK1=WORK2
  465. WORK1.JUN=0
  466. NPTO1=NPTO2
  467. CALL J3ORIE(1,WORK1.XYC,WORK1.DENS,NPTO1,-1,TOL,IRET)
  468. IF(IRET.NE.0)THEN
  469. RETURN
  470. ENDIF
  471. C
  472. C WARNING: ON PROCEDE "B PAR RAPPORT A A" POUR FINIR AVEC LE MEME NB DE
  473. C POINTS EN CAS DE COALESCENCE"
  474. C
  475. DO 40 IE1=1,NTROU1
  476. WORK2=WWORK1.TWORK(IE1)
  477. IF(WORK2.EQ.0)GOTO 40
  478. CALL J3COTO(WORK2,WORK1,TOL,IRET)
  479. IF (IRET.GT.0)THEN
  480. RETURN
  481. ENDIF
  482. CALL J3COTO(WORK1,WORK2,TOL,IRET)
  483. IF (IRET.GT.0)THEN
  484. RETURN
  485. ENDIF
  486. C
  487. NPTO1=WORK1.XYC(/2)
  488. CALL J3TES1(WORK1.IST,NPTO1,LAINB,LAOUB,LAONB,NAONB)
  489. C
  490. NPTO2=WORK2.XYC(/2)
  491. CALL J3TES1(WORK2.IST,NPTO2,LBINA,LBOUA,LBONA,NBONA)
  492. C
  493. C A-T-ON UN CAS 1 DISJOINT? (SI OUI ON PASSE AU TROU SUIVANT)
  494. C
  495. IF(LAOUB.AND.(.NOT.LAONB))THEN
  496. IF(LAINB.OR.LBINA.OR.(.NOT.LBOUA))THEN
  497. IRAISO=43
  498. GOTO 9999
  499. ENDIF
  500. GOTO 40
  501. ENDIF
  502. C
  503. C A-T-ON UN CAS 1 AVEC CONTACT? (SI OUI ON COALESCE)
  504. C (ATTENTION, ON EXCLUT LE CONTACT PONCTUEL EN 1 SEUL POINT)
  505. C
  506. IF((.NOT.LAOUB).AND.(.NOT.LAONB))THEN
  507. IRAISO=43
  508. GOTO 9999
  509. ENDIF
  510. C
  511. CALL J3JUNC(WORK1,WORK2,TOL,IRET)
  512. IF (IRET.GT.0)THEN
  513. RETURN
  514. ENDIF
  515. JUNC=WORK1.JUN
  516. NPTO1=WORK1.XYC(/2)
  517. CALL J3TES2(CRO,NPTO1,LCAINB,LCAOUB,LCAONB)
  518. LACUB=LCAINB.AND.LCAOUB
  519. C
  520. CALL J3JUNC(WORK2,WORK1,TOL,IRET)
  521. IF (IRET.GT.0)THEN
  522. RETURN
  523. ENDIF
  524. NPTO2=WORK2.XYC(/2)
  525. JUNC=WORK2.JUN
  526. CALL J3TES2(CRO,NPTO2,LCBINA,LCBOUA,LCBONA)
  527. C
  528. IF((.NOT.LCAINB).AND.(.NOT.LCBINA).AND.LCAOUB.AND.LCBOUA)THEN
  529. IF(NAONB.EQ.1)GOTO 40
  530. CALL J3JUNC(WORK2,WORK1,TOL,IRET)
  531. CALL J3COAL(WORK1,WORK2,LCAONB,VWORK,NFACEA,TOL,IRET)
  532. IF(IRET.GT.0)THEN
  533. RETURN
  534. ELSE
  535. JUNC=WORK2.JUN
  536. IF(JUNC.NE.0)SEGSUP,JUNC
  537. SEGSUP,WORK2
  538. WWORK1.TWORK(IE1)=0
  539. ENDIF
  540.  
  541. C ATTENTION UNE DES NFACEA FACES EVENTUELLEMENT CREES PEUT
  542. C CONTENIR STRICTEMENT UN DES TROU DE A QUI DEVIENT UN TROU DE LA
  543. C NOUVELLE FACE
  544. C
  545. IF(NFACEA.GT.0)THEN
  546. CALL J3HEAD(WWORK1,VWORK)
  547. CALL J3COAK(WWORK1,VWORK,TOL,IRET)
  548. CALL J3VPLU(VWORK2,VWORK)
  549. ENDIF
  550. ELSE
  551. IRAISO=44
  552. GOTO 9999
  553. ENDIF
  554. 40 CONTINUE
  555. C
  556. C ON REDUIT LE TWORK DE A DU NOMBRE DE COALESCENCE
  557. C
  558. CALL J3REDU(WWORK1)
  559. C
  560. C ON INVERSE MAINTENANT LA NUMEROTATION DE WORK1 DANS WORK2
  561. C
  562. WORK2=WORK1
  563. NPTO2=WORK2.XYC(/2)
  564. CALL J3ORIE(1,WORK2.XYC,WORK2.DENS,NPTO2,1,TOL,IRET)
  565. C PP? CALL J3ORIE(1,WORK2.XYC,WORK2.DENS,NPTO2,-1,TOL,IRET)
  566. IF(IRET.NE.0)THEN
  567. IRAISO=45
  568. GOTO 9999
  569. ENDIF
  570. C
  571. C ON REMET A DANS WORK1 ET ON REFAIT LES TESTS
  572. C
  573. WORK1=WWORK1.FWORK
  574. CALL J3COTO(WORK2,WORK1,TOL,IRET)
  575. IF(IRET.NE.0)THEN
  576. IRAISO=46
  577. GOTO 9999
  578. ENDIF
  579. CALL J3COTO(WORK1,WORK2,TOL,IRET)
  580. IF(IRET.NE.0)THEN
  581. IRAISO=47
  582. GOTO 9999
  583. ENDIF
  584. CALL J3JUNC(WORK1,WORK2,TOL,IRET)
  585. IF(IRET.NE.0)THEN
  586. IRAISO=48
  587. GOTO 9999
  588. ENDIF
  589. C
  590. C C'EST ICI QUE L'ON RE-COUPE (A EST DANS WORK1 ET B COHALESCE
  591. C DANS WORK2)
  592. C
  593. C ON REGARDE D'ABORD EGALEMENT COMMENT B COUPE A
  594. C
  595. CALL J3JUNC(WORK2,WORK1,TOL,IRET)
  596. IF(IRET.NE.0)THEN
  597. IRAISO=49
  598. GOTO 9999
  599. ENDIF
  600. C
  601. C PUIS ON COUPE (ON NE S'INTERESSE QUE A LA PARTIE
  602. C EXTERIEURE VWORK)
  603. C
  604. WWORK1.FWORK=WORK1
  605. CALL J3COUP(WWORK1,WORK2,VWDUMM,VWORK,1,TOL,IRET)
  606. CALL J3DET1(VWDUMM)
  607. C
  608. 45 CALL J3HEAD(WWORK1,VWORK)
  609. CALL J3VPLU(VWORK2,VWORK)
  610. C
  611. RETURN
  612. C
  613. C CONFIGURATION IMPOSSIBLE
  614. C
  615. 9999 CONTINUE
  616. WRITE(IOIMP,*)' J3FAFA: CONFIGURATION IMPOSSIBLE NO.',IRAISO
  617. IRET=IRET+1
  618. RETURN
  619. C
  620. END
  621.  
  622.  
  623.  

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