Télécharger hexa.eso

Retour à la liste

Numérotation des lignes :

  1. C HEXA SOURCE JC220346 16/11/29 21:15:16 9221
  2. C---------------------------------------------------------------------|
  3. C |
  4. SUBROUTINE HEXA(II,JJ,IF1,IF2,IGAGNE)
  5. C |
  6. C CETTE SUBROUTINE TENTE DE CREER UN HEXAEDRE A PARTIR |
  7. C DES QUADRANGLES IF1 ET IF2. |
  8. C - IGAGNE=1 EN CAS DE SUCCES |
  9. C - IGAGNE=0 EN CAS D'ECHEC |
  10. C |
  11. C---------------------------------------------------------------------|
  12. C
  13. IMPLICIT INTEGER(I-N)
  14. IMPLICIT REAL*8(A-H,O-Z)
  15. -INC TDEMAIT
  16. -INC CCOPTIO
  17. LOGICAL REPONS,FACET,SOLHEX,DIAGO,IN2,PLAN,dist2
  18. nfcini=nfcmax
  19. nptini=nptmax
  20. NPTSAU=NPTMAX
  21. C
  22. * WRITE(6,1000)
  23. 1000 FORMAT(' ----->>> HEXA <<<-----')
  24. C
  25. *
  26. * (1) VERIFICATION DE l'ANGLE du diedre
  27. *
  28. ANG=TETA(IF1,if2,ii,jj)
  29. if (ang.lt.-1.d0) return
  30. if (ang.gt.1.d0) goto 1500
  31. IGAGNE=0
  32. L1=0
  33. L2=0
  34. N3=0
  35. N4=0
  36. N5=0
  37. N6=0
  38. IF5=0
  39. IF6=0
  40. ICTF=0
  41. ICTV=0
  42. J1=IPRED(IF1,II)
  43. J2=ISUCC(IF1,JJ)
  44. K1=ISUCC(IF2,II)
  45. K2=IPRED(IF2,JJ)
  46. C
  47. C RECHERCHE DE LA FACETTE IF3
  48. C ---------------------------
  49. C
  50. IF3=IFACE3(K1,II,J1)
  51. * IF (IF3.NE.0) WRITE(6,1010)IF3
  52. 1010 FORMAT(' ** IF3=',I3)
  53. C
  54. IF (IF3.NE.0) THEN
  55. N3=1
  56. IF(NFC(4,IF3).EQ.0) goto 1500
  57. C LA FACETTE DOIT ETRE QUADRANGULAIRE
  58. * write (6,*) ' if3 trouvee',nfc(1,if3),nfc(2,if3),
  59. * # nfc(3,if3),nfc(4,if3)
  60. ANG=TETA(IF1,if3,j1,ii)
  61. if (ang.lt.-1.d0) then
  62. * write (6,*) ' hexa probleme 1'
  63. goto 1500
  64. endif
  65. ANG=TETA(IF2,if3,ii,k1)
  66. if (ang.lt.-1.d0) then
  67. * write (6,*) ' hexa probleme 2'
  68. goto 1500
  69. endif
  70. ENDIF
  71. IF(N3.NE.0) L1=ISUCC(IF3,J1)
  72. C
  73. C RECHERCHE DE LA FACETTE IF4
  74. C ---------------------------
  75. C
  76. IF4=IFACE3(J2,JJ,K2)
  77. * IF (IF4.NE.0) WRITE(6,1020)IF4
  78. 1020 FORMAT(' ** IF4=',I3)
  79. C
  80. IF (IF4.NE.0) THEN
  81. N4=1
  82. IF(NFC(4,IF4).EQ.0) goto 1500
  83. C LA FACETTE DOIT ETRE QUADRANGULAIRE
  84. * write (6,*) ' if4 trouvee',nfc(1,if4),nfc(2,if4),
  85. * # nfc(3,if4),nfc(4,if4)
  86. ANG=TETA(IF1,if4,jj,j2)
  87. if (ang.lt.-1.d0) then
  88. * write (6,*) ' hexa probleme 3'
  89. goto 1500
  90. endif
  91. ANG=TETA(IF2,if4,k2,jj)
  92. if (ang.lt.-1.d0) then
  93. * write (6,*) ' hexa probleme 4'
  94. goto 1500
  95. endif
  96. ENDIF
  97. IF(N4.NE.0) L2=IPRED(IF4,J2)
  98. C
  99. C
  100. C RECHERCHE DE LA FACETTE IF5
  101. C ---------------------------
  102. C
  103. IF(L1*L2.NE.0) THEN
  104. IF5=IFACE4(L1,L2,K1,K2)
  105. if (if5.lt.0) then
  106. * write (6,*) ' if5 trouve 3pts '
  107. return
  108. endif
  109. ELSEIF(L1.NE.0) THEN
  110. IF5=IFACE3(L1,K1,K2)
  111. ELSEIF(L2.NE.0) THEN
  112. IF5=IFACE3(L2,K1,K2)
  113. ELSE
  114. ANG=TETA(IF2,NOISIN(K1,K2,IF2),K1,K2)
  115. IF (ANG.GT.-1.d0) IF5=NOISIN(K1,K2,IF2)
  116. endif
  117. * IF (IF5.NE.0) WRITE(6,1030)IF5
  118. 1030 FORMAT(' ** IF5=',I3)
  119. C
  120. IF (IF5.NE.0) THEN
  121. N5=1
  122. IF(NFC(4,IF5).EQ.0) RETURN
  123. C LA FACETTE DOIT ETRE QUADRANGULAIRE
  124. * write (6,*) ' if5 trouvee',if5,nfc(1,if5),nfc(2,if5),
  125. * # nfc(3,if5),nfc(4,if5)
  126. ENDIF
  127. IF (IF5.NE.0) L1=ISUCC(IF5,K1)
  128. IF (IF5.NE.0) L2=IPRED(IF5,K2)
  129. C
  130. C
  131. C
  132. C RECHERCHE DE LA FACETTE IF6
  133. C ---------------------------
  134. C
  135. IF(L1*l2.NE.0) THEN
  136. IF6=IFACE4(L1,L2,J1,J2)
  137. if (if6.lt.0) then
  138. * write (6,*) ' if6 trouve 3pts '
  139. goto 1500
  140. endif
  141. ELSEIF(L1.NE.0) THEN
  142. IF6=IFACE3(L1,J1,J2)
  143. ELSEIF(L2.NE.0) THEN
  144. IF6=IFACE3(L2,J1,J2)
  145. ELSE
  146. ANG=TETA(IF1,NOISIN(J2,J1,IF1),J2,J1)
  147. IF (ANG.GT.-1.d0) IF6=NOISIN(J2,J1,if1)
  148. endif
  149. * IF (IF6.NE.0) WRITE(6,1040)IF6
  150. 1040 FORMAT(' ** IF5=',I3)
  151. C
  152. IF (IF6.NE.0) THEN
  153. N6=1
  154. IF(NFC(4,IF6).EQ.0) goto 1500
  155. C LA FACETTE DOIT ETRE QUADRANGULAIRE
  156. * write (6,*) ' if6 trouvee',if6,nfc(1,if6),nfc(2,if6),
  157. * # nfc(3,if6),nfc(4,if6)
  158. ENDIF
  159. IF (IF6.NE.0) L1=IPRED(IF6,J1)
  160. IF (IF6.NE.0) L2=ISUCC(IF6,J2)
  161. C
  162. *
  163. * (1) VERIFICATION DES ANGLES AVEC FACETTES ADJACENTES (MINI 90)
  164. *
  165. IF (N6.EQ.0) THEN
  166. ANG=TETA(IF1,NOISIN(J2,J1,IF1),J2,J1)
  167. * write (6,*) 'facette 1 angle 1',ang
  168. IF (ANG.GT.-1.d0) goto 1500
  169. ENDIF
  170. IF (N3.EQ.0) THEN
  171. ANG=TETA(IF1,NOISIN(J1,II,IF1),J1,II)
  172. * write (6,*) 'facette 1 angle 2',ang
  173. IF (ANG.GT.-1.d0) goto 1500
  174. ENDIF
  175. IF (N4.EQ.0) THEN
  176. ANG=TETA(IF1,NOISIN(JJ,J2,IF1),JJ,J2)
  177. * write (6,*) 'facette 1 angle 3',ang
  178. IF (ANG.GT.-1.d0) goto 1500
  179. ENDIF
  180. IF (N5.EQ.0) THEN
  181. ANG=TETA(IF2,NOISIN(K1,K2,IF2),K1,K2)
  182. * write (6,*) 'facette 2 angle 1',ang
  183. IF (ANG.GT.-1.d0) goto 1500
  184. ENDIF
  185. IF (N4.EQ.0) THEN
  186. ANG=TETA(IF2,NOISIN(K2,JJ,IF2),K2,JJ)
  187. * write (6,*) 'facette 2 angle 2',ang
  188. IF (ANG.GT.-1.d0) goto 1500
  189. ENDIF
  190. IF (N3.EQ.0) THEN
  191. ANG=TETA(IF2,NOISIN(II,K1,IF2),II,K1)
  192. * write (6,*) 'facette 2 angle 3',ang
  193. IF (ANG.GT.-1.d0) goto 1500
  194. ENDIF
  195. * a ameliorer plus tard
  196. C
  197. C
  198. C Construction des deux points supplementaires (si necessaire)
  199. C
  200. IF(L1.EQ.0) THEN
  201. L1=NPTMAX+1
  202. NPTMAX=L1
  203. C
  204. C DETERMINATION DES COORDONNEES DU NOUVEAU POINT L1
  205. C -------------------------------------------------
  206. xj1=xyz(1,j1)-xyz(1,ii)
  207. yj1=xyz(2,j1)-xyz(2,ii)
  208. zj1=xyz(3,j1)-xyz(3,ii)
  209. vj1=xj1**2+yj1**2+zj1**2
  210. xk1=xyz(1,k1)-xyz(1,ii)
  211. yk1=xyz(2,k1)-xyz(2,ii)
  212. zk1=xyz(3,k1)-xyz(3,ii)
  213. vk1=xk1**2+yk1**2+zk1**2
  214. scal=xj1*xk1+yj1*yk1+zj1*zk1
  215. xyz(1,l1)=(xyz(1,k1)+xj1-scal*xk1/vk1+
  216. * xyz(1,j1)+xk1-scal*xj1/vj1)*0.5d0
  217. xyz(2,l1)=(xyz(2,k1)+yj1-scal*yk1/vk1+
  218. * xyz(2,j1)+yk1-scal*yj1/vj1)*0.5d0
  219. xyz(3,l1)=(xyz(3,k1)+zj1-scal*zk1/vk1+
  220. * xyz(3,j1)+zk1-scal*zj1/vj1)*0.5d0
  221. DO 150 I=1,3
  222. ****** XYZ(I,L1)=(XYZ(I,L1)+XYZ(I,J1)+XYZ(I,K1)-XYZ(I,II))*0.5d0
  223. XYZ(I,L1)= XYZ(I,J1)+XYZ(I,K1)-XYZ(I,II)
  224. 150 CONTINUE
  225. if (L2.ne.0) then
  226. do 151 i=1,3
  227. XYZ(I,L1)=(XYZ(I,L1)+XYZ(I,J1)+XYZ(I,L2)-XYZ(I,J2)+
  228. * XYZ(I,K1)+XYZ(I,L2)-XYZ(I,K2))/3.d0
  229. 151 continue
  230. endif
  231. XYZ(4,L1)=(XYZ(4,J1)+XYZ(4,K1)+XYZ(4,II))/3.d0
  232. CALL DIST(L1,KP,GL,IOK,II,JJ,J1,J2,K1,K2,L2,0,0,0)
  233. IF (IOK.EQ.0) THEN
  234. * C'est rate
  235. nptmax=nptsau
  236. goto 1500
  237. C l1=kp
  238. C write (6,*) 'hexa point assimile 1 ',kp
  239. C if (diago(l1,j1,0.95D0)) then
  240. C* write (6,*) ' diago quad',l1,j1
  241. C NPTMAX=NPTsau
  242. C goto 1500
  243. C endif
  244. C if (diago(l1,k1,0.95D0)) then
  245. C* write (6,*) ' diago quad',l1,k1
  246. C NPTMAX=NPTsau
  247. C goto 1500
  248. C endif
  249. ENDIF
  250. * if (dist2(l1)) then
  251. * nptmax=nptsau
  252. * return
  253. * endif
  254. XYZ(1,L1+1)=XYZ(1,JJ)+1.35*(XYZ(1,L1)-XYZ(1,JJ))
  255. XYZ(2,L1+1)=XYZ(2,JJ)+1.35*(XYZ(2,L1)-XYZ(2,JJ))
  256. XYZ(3,L1+1)=XYZ(3,JJ)+1.35*(XYZ(3,L1)-XYZ(3,JJ))
  257. XYZ(4,L1+1)=XYZ(4,JJ)+1.35*(XYZ(4,L1)-XYZ(4,JJ))
  258. * IF (.NOT.IN2(jj,L1+1,nfcini)) THEN
  259. * write (6,*) ' in incorrect 1'
  260. * nptmax=nptsau
  261. * goto 1500
  262. * ENDIF
  263. * if (dist2(l1+1)) then
  264. * nptmax=nptsau
  265. * return
  266. * endif
  267. CALL DIST(L1+1,KP,GL,IOK,II,JJ,J1,J2,K1,K2,L1,L2,0,0)
  268. IF (IOK.EQ.0) THEN
  269. * C'est encore rate
  270. NPTMAX=NPTSAU
  271. IF (IVERB.EQ.1) write (6,*) 'point mal place 1.1',kp
  272. goto 1500
  273. ENDIF
  274. ENDIF
  275. * verif que l1 appartient bien a n3 n5 et n6 si ils existent
  276. if (n3.ne.0) then
  277. if (L1.ne.ISUCC(IF3,J1)) then
  278. * write (6,*) ' faces ne correspondent pas '
  279. nptmax=nptsau
  280. goto 1500
  281. endif
  282. endif
  283. if (n5.ne.0) then
  284. if (L1.ne.ISUCC(IF5,K1)) then
  285. * write (6,*) ' faces ne correspondent pas '
  286. nptmax=nptsau
  287. goto 1500
  288. endif
  289. endif
  290. if (n6.ne.0) then
  291. if (L1.ne.IPRED(IF6,J1)) then
  292. * write (6,*) ' faces ne correspondent pas '
  293. nptmax=nptsau
  294. goto 1500
  295. endif
  296. endif
  297. IF(L2.EQ.0) THEN
  298. L2=NPTMAX+1
  299. NPTMAX=L2
  300. C
  301. C DETERMINATION DES COORDONNEES DU NOUVEAU POINT L2
  302. C -------------------------------------------------
  303. xj2=xyz(1,j2)-xyz(1,jj)
  304. yj2=xyz(2,j2)-xyz(2,jj)
  305. zj2=xyz(3,j2)-xyz(3,jj)
  306. vj2=xj2**2+yj2**2+zj2**2
  307. xk2=xyz(1,k2)-xyz(1,jj)
  308. yk2=xyz(2,k2)-xyz(2,jj)
  309. zk2=xyz(3,k2)-xyz(3,jj)
  310. vk2=xk2**2+yk2**2+zk2**2
  311. scal=xj2*xk2+yj2*yk2+zj2*zk2
  312. xyz(1,l2)=(xyz(1,k2)+xj2-scal*xk2/vk2+
  313. * xyz(1,j2)+xk2-scal*xj2/vj2)*0.5d0
  314. xyz(2,l2)=(xyz(2,k2)+yj2-scal*yk2/vk2+
  315. * xyz(2,j2)+yk2-scal*yj2/vj2)*0.5d0
  316. xyz(3,l2)=(xyz(3,k2)+zj2-scal*zk2/vk2+
  317. * xyz(3,j2)+zk2-scal*zj2/vj2)*0.5d0
  318. DO 170 I=1,3
  319. ********** XYZ(I,L2)=(XYZ(I,L2)+XYZ(I,J2)+XYZ(I,K2)-XYZ(I,JJ))*0.5d0
  320. XYZ(I,L2)= XYZ(I,J2)+XYZ(I,K2)-XYZ(I,JJ)
  321. 170 CONTINUE
  322. if (L1.ne.0) then
  323. do 171 i=1,3
  324. XYZ(I,L2)=(XYZ(I,L2)+XYZ(I,J2)+XYZ(I,L1)-XYZ(I,J1)+
  325. * XYZ(I,L1)+XYZ(I,K2)-XYZ(I,K1))/3.d0
  326. 171 continue
  327. endif
  328. XYZ(4,L2)=(XYZ(4,J2)+XYZ(4,K2)+XYZ(4,JJ))/3.d0
  329. CALL DIST(L2,KP,GL,IOK,II,JJ,J1,J2,K1,K2,L1,0,0,0)
  330. IF (IOK.EQ.0) THEN
  331. * C'est rate
  332. nptmax=nptsau
  333. goto 1500
  334. C l2=kp
  335. C write (6,*) 'hexa point assimile 2 ',kp
  336. C if (diago(l2,j2,0.95d0)) then
  337. C* write (6,*) ' diago quad',l1,j1
  338. C NPTMAX=NPTsau
  339. C goto 1500
  340. C endif
  341. C if (diago(l2,k2,0.95d0)) then
  342. C* write (6,*) ' diago quad',l2,k2
  343. C NPTMAX=NPTsau
  344. C goto 1500
  345. C endif
  346. C if (diago(l2,l1,0.95d0)) then
  347. C* write (6,*) ' diago quad',l2,l1
  348. C NPTMAX=NPTsau
  349. C goto 1500
  350. C endif
  351. ENDIF
  352. * if (dist2(l2)) then
  353. * nptmax=nptsau
  354. * return
  355. * endif
  356. XYZ(1,L2+1)=XYZ(1,II)+1.35*(XYZ(1,L2)-XYZ(1,II))
  357. XYZ(2,L2+1)=XYZ(2,II)+1.35*(XYZ(2,L2)-XYZ(2,II))
  358. XYZ(3,L2+1)=XYZ(3,II)+1.35*(XYZ(3,L2)-XYZ(3,II))
  359. XYZ(4,L2+1)=XYZ(4,II)+1.35*(XYZ(4,L2)-XYZ(4,II))
  360. * IF (.NOT.IN2(ii,L2+1,nfcini)) THEN
  361. * write (6,*) ' in incorrect 2'
  362. * nptmax=nptsau
  363. * goto 1500
  364. * ENDIF
  365. * if (dist2(l2+1)) then
  366. * nptmax=nptsau
  367. * return
  368. * endif
  369. CALL DIST(L2+1,KP,GL,IOK,II,JJ,J1,J2,K1,K2,L1,L2,0,0)
  370. IF (IOK.EQ.0) THEN
  371. ** C'est encore rate
  372. NPTMAX=NPTSAU
  373. IF (IVERB.EQ.1) write (6,*) 'point mal place 2.2',kp
  374. goto 1500
  375. ENDIF
  376. ENDIF
  377. * verif que l2 appartient bien a n4 n5 et n6 si ils existent
  378. if (n4.ne.0) then
  379. if (L2.ne.IPRED(IF4,J2)) then
  380. * write (6,*) ' faces ne correspondent pas '
  381. nptmax=nptsau
  382. goto 1500
  383. endif
  384. endif
  385. if (n5.ne.0) then
  386. if (L2.ne.IPRED(IF5,K2)) then
  387. * write (6,*) ' faces ne correspondent pas '
  388. nptmax=nptsau
  389. goto 1500
  390. endif
  391. endif
  392. if (n6.ne.0) then
  393. if (L2.ne.ISUCC(IF6,J2)) then
  394. * write (6,*) ' faces ne correspondent pas '
  395. nptmax=nptsau
  396. goto 1500
  397. endif
  398. endif
  399. IF (DIAGO(L1,L2,0.95D0)) THEN
  400. * write (6,*) ' diago quad',L1,L2
  401. NPTMAX=NPTsau
  402. goto 1500
  403. ENDIF
  404. C
  405. C
  406. C
  407. C CONSTRUCTION DU CUBE
  408. C --------------------
  409. C
  410. IF (IF3.EQ.0) THEN
  411. C
  412. C CREATION DE LA FACETTE IF3
  413. C --------------------------
  414. IF3=IFACE4(IPRED(IF1,II),II,ISUCC(IF2,II),L1)
  415. if (if3.lt.0) then
  416. * write (6,*) ' if3 trouve 3pts '
  417. nfcmax=nfcini
  418. nptmax=nptini
  419. return
  420. elseif (if3.eq.0) then
  421. NFCMAX=NFCMAX+1
  422. IF3=NFCMAX
  423. ICTF=ICTF+1
  424. C
  425. NFC(1,IF3)=IPRED(IF1,II)
  426. NFC(2,IF3)=II
  427. NFC(3,IF3)=ISUCC(IF2,II)
  428. NFC(4,IF3)=L1
  429. C
  430. ENDIF
  431. ENDIF
  432. C
  433. C
  434. IF (IF4.EQ.0) THEN
  435. C
  436. C CREATION DE LA FACETTE IF4
  437. C --------------------------
  438. IF4=IFACE4(JJ,ISUCC(IF1,JJ),L2,IPRED(IF2,JJ))
  439. if (if4.lt.0) then
  440. * write (6,*) ' if4 trouve 3pts '
  441. nfcmax=nfcini
  442. nptmax=nptini
  443. return
  444. elseif (if4.eq.0) then
  445. NFCMAX=NFCMAX+1
  446. IF4=NFCMAX
  447. ICTF=ICTF+1
  448. C
  449. NFC(1,IF4)=JJ
  450. NFC(2,IF4)=ISUCC(IF1,JJ)
  451. NFC(3,IF4)=L2
  452. NFC(4,IF4)=IPRED(IF2,JJ)
  453. C
  454. ENDIF
  455. ENDIF
  456. C
  457. C
  458. IF (IF5.EQ.0) THEN
  459. C
  460. C CREATION DE LA FACETTE IF5
  461. C --------------------------
  462. IF5=IFACE4(l1,k1,k2,l2)
  463. if (if5.lt.0) then
  464. * write (6,*) ' if5 trouve 3pts '
  465. nfcmax=nfcini
  466. nptmax=nptini
  467. return
  468. elseif (if5.eq.0) then
  469. NFCMAX=NFCMAX+1
  470. IF5=NFCMAX
  471. ICTF=ICTF+1
  472. C
  473. NFC(1,IF5)=L1
  474. NFC(2,IF5)=K1
  475. NFC(3,IF5)=K2
  476. NFC(4,IF5)=L2
  477. C
  478. C
  479. ENDIF
  480. ENDIF
  481. IF (IF6.EQ.0) THEN
  482. C
  483. C CREATION DE LA FACETTE IF6
  484. C --------------------------
  485. IF6=IFACE4(j1,l1,l2,j2)
  486. if (if6.lt.0) then
  487. * write (6,*) ' if6 trouve 3pts '
  488. nfcmax=nfcini
  489. nptmax=nptini
  490. return
  491. elseif (if6.eq.0) then
  492. NFCMAX=NFCMAX+1
  493. IF6=NFCMAX
  494. ICTF=ICTF+1
  495. C
  496. NFC(1,IF6)=J1
  497. NFC(2,IF6)=L1
  498. NFC(3,IF6)=L2
  499. NFC(4,IF6)=J2
  500. C
  501. C
  502. ENDIF
  503. ENDIF
  504. C
  505. C ON ENLEVE LES FACETTES IF1, IF2 ET IF3
  506. C --------------------------------------
  507. CALL REPSUB(IF1)
  508. CALL REPSUB(IF2)
  509. CALL REPSUB(IF3)
  510. CALL REPSUB(IF4)
  511. CALL REPSUB(IF5)
  512. CALL REPSUB(IF6)
  513. C
  514. C LE VOLUME CREE EST-IL VALIDE ?
  515. C ------------------------------
  516. IF (.NOT.PLAN(IF3)) GOTO 160
  517. * write (6,*) ' plan(if3) passe'
  518. IF (.NOT.PLAN(IF4)) GOTO 160
  519. * write (6,*) ' plan(if4) passe'
  520. IF (.NOT.PLAN(IF5)) GOTO 160
  521. * write (6,*) ' plan(if5) passe'
  522. IF (.NOT.PLAN(IF6)) GOTO 160
  523. * write (6,*) ' plan(if6) passe'
  524. IF (.NOT.FACET(IF3)) GOTO 160
  525. * write (6,*) ' facet(if3) passe'
  526. IF (.NOT.FACET(IF4)) GOTO 160
  527. * write (6,*) ' facet(if4) passe'
  528. IF (.NOT.FACET(IF5)) GOTO 160
  529. * write (6,*) ' facet(if5) passe'
  530. IF (.NOT.FACET(IF6)) GOTO 160
  531. * write (6,*) ' facet(if6) passe'
  532. IF (.NOT.SOLHEX(IF1,IF2,IF3,IF4,IF5,IF6)) GOTO 160
  533. * write (6,*) ' solhex passe'
  534. *
  535. * VERIFICATION TAILLE
  536. IF (N3.EQ.0.AND.N5.EQ.0) THEN
  537. KF1=IPRED(IF1,II)
  538. KF2=ISUCC(IF2,II)
  539. DNORM=(XYZ(1,KF1)-XYZ(1,KF2))**2
  540. # +(XYZ(2,KF1)-XYZ(2,KF2))**2
  541. # +(XYZ(3,KF1)-XYZ(3,KF2))**2
  542. DTEST=tcrit*XYZ(4,KF1)*XYZ(4,KF2)
  543. IF (DNORM.GT.DTEST) GOTO 160
  544. ENDIF
  545. IF (N4.EQ.0.AND.N5.EQ.0) THEN
  546. KF1=IPRED(IF2,JJ)
  547. KF2=ISUCC(IF1,JJ)
  548. DNORM=(XYZ(1,KF1)-XYZ(1,KF2))**2
  549. # +(XYZ(2,KF1)-XYZ(2,KF2))**2
  550. # +(XYZ(3,KF1)-XYZ(3,KF2))**2
  551. DTEST=tcrit*XYZ(4,KF1)*XYZ(4,KF2)
  552. IF (DNORM.GT.DTEST) GOTO 160
  553. ENDIF
  554. * write (6,*) 'hexa a cree un cube numero nfacet ',nvol+1,nfacet
  555. C
  556. C LE VOLUME CREE EST VALIDE |
  557. C ---------------------------
  558. C MEMORISATION DU VOLUME IF1, IF2, IF3, IF4 ET IF5
  559. C ------------------------------------------------
  560. NVOL=NVOL+1
  561. IF (NFV(1,IF1).EQ.0) NFV(1,IF1)=NVOL
  562. IF (NFV(1,IF1).NE.NVOL) NFV(2,IF1)=NVOL
  563. IF (NFV(1,IF2).EQ.0) NFV(1,IF2)=NVOL
  564. IF (NFV(1,IF2).NE.NVOL) NFV(2,IF2)=NVOL
  565. IF (NFV(1,IF3).EQ.0) NFV(1,IF3)=NVOL
  566. IF (NFV(1,IF3).NE.NVOL) NFV(2,IF3)=NVOL
  567. IF (NFV(1,IF4).EQ.0) NFV(1,IF4)=NVOL
  568. IF (NFV(1,IF4).NE.NVOL) NFV(2,IF4)=NVOL
  569. IF (NFV(1,IF5).EQ.0) NFV(1,IF5)=NVOL
  570. IF (NFV(1,IF5).NE.NVOL) NFV(2,IF5)=NVOL
  571. IF (NFV(1,IF6).EQ.0) NFV(1,IF6)=NVOL
  572. IF (NFV(1,IF6).NE.NVOL) NFV(2,IF6)=NVOL
  573. IVOL(9,NVOL)=20
  574. IVOL(1,NVOL)=II
  575. IVOL(2,NVOL)=JJ
  576. IVOL(3,NVOL)=J2
  577. IVOL(4,NVOL)=J1
  578. IVOL(5,NVOL)=K1
  579. IVOL(6,NVOL)=K2
  580. IVOL(7,NVOL)=L2
  581. IVOL(8,NVOL)=L1
  582. C
  583. * WRITE(6,1100)NVOL,(IVOL(I,NVOL),I=1,9)
  584. if (iimpi.eq.1) write (6,1100) nfacet,(ivol(i,nvol),i=1,8)
  585. 1100 FORMAT(' HEXA facettes ',i5,' cub8 ',8i5)
  586. C
  587. * DO 150 J=1,NPTMAX
  588. * WRITE(6,1110)J,(NPF(I,J),I=1,40)
  589. *1110 FORMAT(I4,4X,40I3)
  590. *150 CONTINUE
  591. C
  592. IGAGNE=1
  593. C
  594. RETURN
  595. C
  596. 160 CONTINUE
  597. * write (6,*) ' probleme en validant le cube '
  598. C
  599. C LE VOLUME CREE N'EST PAS VALIDE: IL FAUT DONC DETRUIRE LES FACETT
  600. C CREEES. ---------------------------------------------------------
  601. CALL REPSUB(IF1)
  602. CALL REPSUB(IF2)
  603. CALL REPSUB(IF3)
  604. CALL REPSUB(IF4)
  605. CALL REPSUB(IF5)
  606. CALL REPSUB(IF6)
  607. C
  608. NFCMAX=NFCMAX-ICTF
  609. C
  610. NPTMAX=NPTSAU
  611. 1500 continue
  612. * maintenant on essaye un prisme
  613. NPTMAX=NPTSAU
  614. * call prism1(II,JJ,IF1,IF2,IGAGNE)
  615. return
  616. end
  617.  
  618.  
  619.  
  620.  
  621.  
  622.  
  623.  

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