Télécharger com433.eso

Retour à la liste

Numérotation des lignes :

  1. C COM433 SOURCE JC220346 16/11/29 21:15:04 9221
  2. C---------------------------------------------------------------------|
  3. C |
  4. SUBROUTINE COM433(II,MF1,MF2,MF3,IGAGNE)
  5. C |
  6. C CETTE SUBROUTINE TENTE DE CREER 1 PYRAMIDE ET 2 TETRAEDRES |
  7. C A PARTIR DU QUADRANGLE IF1 ET DES TRIANGLES IF2 ET IF3 EN |
  8. C CREANT UN POINT CENTRAL SUPPLEMENTAIRE |
  9. C - IGAGNE=1 EN CAS DE SUCCES |
  10. C - IGAGNE=0 EN CAS D'ECHEC |
  11. C |
  12. C---------------------------------------------------------------------|
  13. C
  14. IMPLICIT INTEGER(I-N)
  15. IMPLICIT REAL*8(A-H,O-Z)
  16. -INC TDEMAIT
  17. -INC CCOPTIO
  18. LOGICAL REPONS,FACET,SOLPYR,SOLTET,IN2,diago
  19. nfcini=nfcmax
  20. nptini=nptmax
  21. nvini=nvol
  22. ICTP=0
  23. ipin = 0
  24. C
  25. C METTRE LES FACES DANS L'ORDRE
  26. IF1=MF1
  27. IP=ISUCC(IF1,II)
  28. IF (IP.EQ.IPRED(MF2,II)) IF2=MF2
  29. IF (IP.EQ.IPRED(MF3,II)) IF2=MF3
  30. IP=ISUCC(IF2,II)
  31. IF (IP.EQ.IPRED(MF2,II)) IF3=MF2
  32. IF (IP.EQ.IPRED(MF3,II)) IF3=MF3
  33. * WRITE(6,1000)IF1,IF2,IF3
  34. 1000 FORMAT(' COM433 IF1=',I5,' IF2=',I5,' IF3=',I5)
  35. C
  36. ICTF=0
  37. ICTV=0
  38. C
  39. C
  40. C CREATION DU POINT CENTRAL : IP
  41. C ------------------------------
  42. IP1=II
  43. IP2=ISUCC(IF1,IP1)
  44. IP3=ISUCC(IF1,IP2)
  45. IP4=ISUCC(IF1,IP3)
  46. ICTP=1
  47. NPTMAX=NPTMAX+1
  48. IP=NPTMAX
  49. C
  50. DO 100 I=1,4
  51. * XYZ(I,IP)=(XYZ(I,IP1)+XYZ(I,IP2)+XYZ(I,IP3)
  52. * # +XYZ(I,IP4))/4.
  53. XYZ(I,IP)=(XYZ(I,IP2)+XYZ(I,IP4))/2.
  54. 100 CONTINUE
  55. JP1=II
  56. JP2=ISUCC(IF2,JP1)
  57. JP3=ISUCC(IF2,JP2)
  58. C
  59. DO 102 I=1,4
  60. XYZ(I,IP)=XYZ(I,IP)+
  61. # (XYZ(I,JP2)+XYZ(I,JP3))/2.
  62. 102 CONTINUE
  63. KP1=II
  64. KP2=ISUCC(IF3,KP1)
  65. KP3=ISUCC(IF3,KP2)
  66. C
  67. DO 104 I=1,4
  68. XYZ(I,IP)=(XYZ(I,IP)+
  69. # (XYZ(I,KP2)+XYZ(I,KP3))/2.)/3.
  70. 104 CONTINUE
  71. DO 103 I=1,3
  72. XYZ(I,IP)=XYZ(I,II)+expcom*(XYZ(I,IP)-XYZ(I,II))
  73. 103 CONTINUE
  74. C
  75. * WRITE(6,1010)IP,(XYZ(I,IP),I=1,4)
  76. 1010 FORMAT(' POINT:',I3,':',4F7.2)
  77. C
  78. * verif des volumes
  79. if ((vol(ip,ii,ip2,ip4).gt.0).or.
  80. > (vol(ip,ii,jp2,jp3).gt.0).or.
  81. > (vol(ip,ii,kp2,kp3).gt.0)) then
  82. IF (IVERB.EQ.1) write (6,*) ' com433 volume positif '
  83. nptmax=nptini
  84. return
  85. endif
  86. C
  87. CALL DIST(IP,JP,GL,IOK,IP1,IP2,IP3,IP4,JP2,JP3,KP2,KP3,0,0)
  88. IF (IOK.EQ.0) THEN
  89. NPTMAX=NPTini
  90. RETURN
  91. ICTP=0
  92. NPTMAX=NPTMAX-1
  93. IP=JP
  94. return
  95. * WRITE (6,*) ' COM433 POINT ASSIMILE ',JP
  96. ENDIF
  97. REPONS=IN2(ii,IP,nfcini)
  98. IF (REPONS) GOTO 110
  99. NPTMAX=NPTini
  100. RETURN
  101. C
  102. 110 CONTINUE
  103. C
  104. C CREATION D'UNE PYRAMIDE : IF1+IP
  105. C --------------------------------
  106. IP1=ISUCC(IF1,II)
  107. IP2=ISUCC(IF1,IP1)
  108. IP3=ISUCC(IF1,IP2)
  109. * recherche existence de la face
  110. jf1=IFACE3(ip,ii,ip1)
  111. * IF (jf1.ne.0) write (6,*) ' com433 facette assimilee'
  112. IF (jf1.eq.0) THEN
  113. nfcmax=nfcmax+1
  114. jf1=nfcmax
  115. NFC(1,jf1)=ip
  116. NFC(2,jf1)=ii
  117. NFC(3,jf1)=ip1
  118. NFC(4,jf1)=0
  119. elseif (NFC(4,jf1).ne.0.or.ipred(jf1,ii).ne.ip1) then
  120. jf1=0
  121. endif
  122. * write (6,*) ' com433 jf1 passe ',jf1
  123. C
  124. * recherche existence de la face
  125. jf2=IFACE3(ip,ip1,ip2)
  126. * IF (jf2.ne.0) write (6,*) ' com433 facette assimilee'
  127. IF (jf2.eq.0) THEN
  128. nfcmax=nfcmax+1
  129. jf2=nfcmax
  130. NFC(1,jf2)=ip
  131. NFC(2,jf2)=ip1
  132. NFC(3,jf2)=ip2
  133. NFC(4,jf2)=0
  134. elseif (NFC(4,jf2).ne.0.or.ipred(jf2,ip).ne.ip1) then
  135. jf2=0
  136. endif
  137. if (NFC(4,jf2).ne.0) jf2=0
  138. * write (6,*) ' com433 jf2 passe ',jf2
  139. C
  140. * recherche existence de la face
  141. jf3=IFACE3(ip,ip2,ip3)
  142. * IF (jf3.ne.0) write (6,*) ' com433 facette assimilee'
  143. IF (jf3.eq.0) THEN
  144. nfcmax=nfcmax+1
  145. jf3=nfcmax
  146. NFC(1,jf3)=ip
  147. NFC(2,jf3)=ip2
  148. NFC(3,jf3)=ip3
  149. NFC(4,jf3)=0
  150. elseif (NFC(4,jf3).ne.0.or.ipred(jf3,ip).ne.ip2) then
  151. jf3=0
  152. endif
  153. * write (6,*) ' com433 jf3 passe ',jf3
  154. C
  155. * recherche existence de la face
  156. jf4=IFACE3(ip,ip3,ii)
  157. * IF (jf4.ne.0) write (6,*) ' com433 facette assimilee'
  158. IF (jf4.eq.0) THEN
  159. nfcmax=nfcmax+1
  160. jf4=nfcmax
  161. NFC(1,jf4)=ip
  162. NFC(2,jf4)=ip3
  163. NFC(3,jf4)=ii
  164. NFC(4,jf4)=0
  165. elseif (NFC(4,jf4).ne.0.or.ipred(jf4,ip).ne.ip3) then
  166. jf4=0
  167. endif
  168. if (NFC(4,jf4).ne.0) jf4=0
  169. * write (6,*) ' com433 jf4 passe ',jf4
  170. C
  171. if (diago(ip,ii,diacrd)) then
  172. jf4=0
  173. jf1=0
  174. endif
  175. if (diago(ip,ip1,diacrd)) then
  176. * write (6,*) ' com433 jf4 echec diago - 1 ',ip,ip1
  177. jf1=0
  178. jf2=0
  179. endif
  180. if (diago(ip,ip2,diacrd)) then
  181. * write (6,*) ' com433 jf4 echec diago - 2 ',ip,ip2
  182. jf2=0
  183. jf3=0
  184. endif
  185. if (diago(ip,ip3,diacrd)) then
  186. * write (6,*) ' com433 jf4 echec diago - 3 ',ip,ip3
  187. jf3=0
  188. jf4=0
  189. endif
  190. if (jf1*jf2*jf3*jf4.eq.0) then
  191. * write (6,*) 'com433 impossibilite '
  192. nfcmax=nfcini
  193. jf1=0
  194. jf2=0
  195. jf3=0
  196. jf4=0
  197. goto 131
  198. endif
  199. CALL REPSUB(IF1)
  200. CALL REPSUB(JF1)
  201. CALL REPSUB(JF2)
  202. CALL REPSUB(JF3)
  203. CALL REPSUB(JF4)
  204. C
  205. C LE VOLUME CREE EST-IL VALIDE ?
  206. C ------------------------------
  207. IF (.not.SOLPYR(IF1,JF1,JF2,JF3,JF4)) GOTO 129
  208. IF (.NOT.FACET(jf1)) GOTO 129
  209. IF (.NOT.FACET(jf2)) GOTO 129
  210. IF (.NOT.FACET(jf3)) GOTO 129
  211. IF (.NOT.FACET(jf4)) GOTO 129
  212. goto 130
  213. C
  214. C LE VOLUME EST INVALIDE
  215. C ----------------------
  216. 129 continue
  217. * write (6,*) ' solpyr 1 invalide'
  218. NFCMAX=NFCini
  219. CALL REPSUB(JF4)
  220. CALL REPSUB(JF3)
  221. CALL REPSUB(JF2)
  222. CALL REPSUB(JF1)
  223. CALL REPSUB(IF1)
  224. jf1=0
  225. jf2=0
  226. jf3=0
  227. jf4=0
  228. goto 131
  229. C
  230. 130 CONTINUE
  231. C
  232. C MEMORISATION DU VOLUME OBTENU : IF1, JF1, JF2, JF3 ET JF4
  233. C ---------------------------------------------------------
  234. ICTV=ICTV+1
  235. NVOL=NVOL+1
  236. IF (NFV(1,IF1).EQ.0) NFV(1,IF1)=NVOL
  237. IF (NFV(1,IF1).NE.NVOL) NFV(2,IF1)=NVOL
  238. IF (NFV(1,JF1).EQ.0) NFV(1,JF1)=NVOL
  239. IF (NFV(1,JF1).NE.NVOL) NFV(2,JF1)=NVOL
  240. IF (NFV(1,JF2).EQ.0) NFV(1,JF2)=NVOL
  241. IF (NFV(1,JF2).NE.NVOL) NFV(2,JF2)=NVOL
  242. IF (NFV(1,JF3).EQ.0) NFV(1,JF3)=NVOL
  243. IF (NFV(1,JF3).NE.NVOL) NFV(2,JF3)=NVOL
  244. IF (NFV(1,JF4).EQ.0) NFV(1,JF4)=NVOL
  245. IF (NFV(1,JF4).NE.NVOL) NFV(2,JF4)=NVOL
  246. IVOL(9,NVOL)=35
  247. C
  248. DO 140 I=1,4
  249. IVOL(I,NVOL)=NFC(I,IF1)
  250. 140 CONTINUE
  251. IVOL(5,NVOL)=IP
  252. *C
  253. if (iimpi.eq.1) write (6,1100) nfacet,(ivol(i,nvol),i=1,5)
  254. 1100 FORMAT(' COM433-1 facettes ',i5,' PYR5 ',5i5)
  255. *C
  256. * DO 150 J=1,NPTMAX
  257. * WRITE(6,1110)J,(NPF(I,J),I=1,40)
  258. 1110 FORMAT(I4,4X,40I3)
  259. *150 CONTINUE
  260. C PV INC
  261. C
  262. 131 continue
  263. if (nvol.eq.nvini) then
  264. nptmax=nptini
  265. return
  266. endif
  267. nfcini=nfcmax
  268. C 2EME VOLUME : IF2+IP
  269. C --------------------
  270. IP1=ISUCC(IF2,II)
  271. IP2=ISUCC(IF2,IP1)
  272. C
  273. * recherche existence de la face
  274. kf1=IFACE3(ip,ii,ip1)
  275. * IF (kf1.ne.0) write (6,*) ' com433 facette assimilee'
  276. IF (kf1.eq.0) THEN
  277. nfcmax=nfcmax+1
  278. kf1=nfcmax
  279. NFC(1,kf1)=ip
  280. NFC(2,kf1)=ii
  281. NFC(3,kf1)=ip1
  282. NFC(4,kf1)=0
  283. elseif (NFC(4,kf1).ne.0.or.ipred(kf1,ip).ne.ii) then
  284. kf1=0
  285. endif
  286. * write (6,*) ' com433 kf1 passe ',kf1
  287. C
  288. * recherche existence de la face
  289. kf2=IFACE3(ip,ip1,ip2)
  290. * IF (kf2.ne.0) write (6,*) ' com433 facette assimilee'
  291. IF (kf2.eq.0) THEN
  292. nfcmax=nfcmax+1
  293. kf2=nfcmax
  294. NFC(1,kf2)=ip
  295. NFC(2,kf2)=ip1
  296. NFC(3,kf2)=ip2
  297. NFC(4,kf2)=0
  298. elseif (NFC(4,kf2).ne.0.or.ipred(kf2,ip).ne.ip1) then
  299. kf2=0
  300. endif
  301. * write (6,*) ' com433 kf2 passe ',kf2
  302. C
  303. * recherche existence de la face
  304. kf3=IFACE3(ip,ip2,ii)
  305. * IF (kf3.ne.0) write (6,*) ' com433 facette assimilee'
  306. IF (kf3.eq.0) THEN
  307. nfcmax=nfcmax+1
  308. kf3=nfcmax
  309. NFC(1,kf3)=ip
  310. NFC(2,kf3)=ip2
  311. NFC(3,kf3)=ii
  312. NFC(4,kf3)=0
  313. elseif (NFC(4,kf3).ne.0.or.ipred(kf3,ip).ne.ip2) then
  314. kf3=0
  315. endif
  316. * write (6,*) ' com433 kf3 passe ',kf3
  317. C
  318. if (diago(ip,ii,diacrd)) then
  319. kf3=0
  320. kf1=0
  321. endif
  322. if (diago(ip,ip1,diacrd)) then
  323. kf1=0
  324. kf2=0
  325. endif
  326. if (diago(ip,ip2,diacrd)) then
  327. kf2=0
  328. kf3=0
  329. endif
  330. if (kf1*kf2*kf3.eq.0) then
  331. * write (6,*) 'com433 impossibilite '
  332. nfcmax=nfcini
  333. kf1=0
  334. kf2=0
  335. kf3=0
  336. goto 161
  337. endif
  338. CALL REPSUB(IF2)
  339. CALL REPSUB(KF1)
  340. CALL REPSUB(KF2)
  341. CALL REPSUB(KF3)
  342. C
  343. C LE VOLUME CREE EST-IL VALIDE ?
  344. C ------------------------------
  345. if (.not.SOLTET(IF2,KF1,KF2,KF3,ipin)) goto 160
  346. IF (.NOT.FACET(kF1)) GOTO 160
  347. IF (.NOT.FACET(kF2)) GOTO 160
  348. IF (.NOT.FACET(kF3)) GOTO 160
  349. GOTO 170
  350. C
  351. 160 CONTINUE
  352. C
  353. * write (6,*) ' soltet 2 invalide'
  354. NFCMAX=NFCini
  355. CALL REPSUB(KF3)
  356. CALL REPSUB(KF2)
  357. CALL REPSUB(KF1)
  358. CALL REPSUB(IF2)
  359. kf1=0
  360. kf2=0
  361. kf3=0
  362. goto 161
  363. C
  364. 170 CONTINUE
  365. C
  366. C MEMORISATION DU VOLUME IF2, LF1, KF2, KF3 ET LF4
  367. C ------------------------------------------------
  368. ICTV=ICTV+1
  369. NVOL=NVOL+1
  370. IF (NFV(1,IF2).EQ.0) NFV(1,IF2)=NVOL
  371. IF (NFV(1,IF2).NE.NVOL) NFV(2,IF2)=NVOL
  372. IF (NFV(1,kF1).EQ.0) NFV(1,kF1)=NVOL
  373. IF (NFV(1,kF1).NE.NVOL) NFV(2,kF1)=NVOL
  374. IF (NFV(1,kF2).EQ.0) NFV(1,kF2)=NVOL
  375. IF (NFV(1,kF2).NE.NVOL) NFV(2,kF2)=NVOL
  376. IF (NFV(1,kF3).EQ.0) NFV(1,kF3)=NVOL
  377. IF (NFV(1,kF3).NE.NVOL) NFV(2,kF3)=NVOL
  378. IVOL(9,NVOL)=25
  379. C
  380. DO 180 I=1,3
  381. IVOL(I,NVOL)=NFC(I,IF2)
  382. 180 CONTINUE
  383. IVOL(4,NVOL)=IP
  384. if (iimpi.eq.1) write (6,1180) nfacet,(ivol(i,nvol),i=1,4)
  385. 1180 FORMAT(' COM433-2 facettes ',i5,' TET4 ',4i5)
  386. *C
  387. * DO 190 J=1,NPTMAX
  388. * WRITE(6,1190)J,(NPF(I,J),I=1,40)
  389. 1190 FORMAT(I4,4X,40I3)
  390. *190 CONTINUE
  391. C
  392. 161 continue
  393. nfcini=nfcmax
  394. C
  395. C 3EME VOLUME : IF3+IP
  396. C --------------------
  397. IP1=ISUCC(IF3,II)
  398. IP2=ISUCC(IF3,IP1)
  399. C ON RETOMBE SUR JF4 (si on ne l'a pas detruit)
  400. C
  401. lf1=IFACE3(ip,ii,ip1)
  402. * IF (lf1.ne.0) write (6,*) ' com433 facette deja existante'
  403. IF (lf1.eq.0) THEN
  404. nfcmax=nfcmax+1
  405. lf1=nfcmax
  406. NFC(1,lf1)=ip
  407. NFC(2,lf1)=ii
  408. NFC(3,lf1)=ip1
  409. NFC(4,lf1)=0
  410. elseif (NFC(4,lf1).ne.0.or.ipred(lf1,ip).ne.ii) then
  411. lf1=0
  412. endif
  413. * write (6,*) ' com433 lf1 passe ',lf1
  414. C
  415. C
  416. * recherche existence de la face
  417. lf2=IFACE3(ip,ip1,ip2)
  418. * IF (lf2.ne.0) write (6,*) ' com433 facette assimilee'
  419. IF (lf2.eq.0) THEN
  420. nfcmax=nfcmax+1
  421. lf2=nfcmax
  422. NFC(1,lf2)=ip
  423. NFC(2,lf2)=ip1
  424. NFC(3,lf2)=ip2
  425. NFC(4,lf2)=0
  426. elseif (NFC(4,lf2).ne.0.or.ipred(lf2,ip).ne.ip1) then
  427. lf2=0
  428. endif
  429. * write (6,*) ' com433 lf2 passe ',lf2
  430. C
  431. C ON RETOMBE SUR KF1 (si on ne l'a pas detruit)
  432. C
  433. lf3=IFACE3(ip,ip2,ii)
  434. * IF (lf3.ne.0) write (6,*) ' com433 facette deja existante'
  435. IF (lf3.eq.0) THEN
  436. nfcmax=nfcmax+1
  437. lf3=nfcmax
  438. NFC(1,lf3)=ip
  439. NFC(2,lf3)=ip2
  440. NFC(3,lf3)=ii
  441. NFC(4,lf3)=0
  442. elseif (NFC(4,lf3).ne.0.or.ipred(lf3,ip).ne.ip2) then
  443. lf3=0
  444. endif
  445. * write (6,*) ' com433 lf3 passe ',lf3
  446. C
  447. if (diago(ip,ii,diacrd)) then
  448. lf3=0
  449. lf1=0
  450. endif
  451. if (diago(ip,ip1,diacrd)) then
  452. lf1=0
  453. lf2=0
  454. endif
  455. if (diago(ip,ip2,diacrd)) then
  456. lf2=0
  457. lf3=0
  458. endif
  459. if (lf1*lf2*lf3.eq.0) then
  460. * write (6,*) 'com433 impossibilite '
  461. NFCMAX=NFCini
  462. goto 201
  463. endif
  464. C
  465. C
  466. CALL REPSUB(IF3)
  467. CALL REPSUB(LF1)
  468. CALL REPSUB(LF2)
  469. CALL REPSUB(LF3)
  470. C
  471. C LE VOLUME CREE EST-IL VALIDE ?
  472. C ------------------------------
  473. IF (.NOT.SOLTET(IF3,LF1,LF2,LF3,ipin)) goto 200
  474. IF (.NOT.FACET(LF1)) GOTO 200
  475. IF (.NOT.FACET(LF2)) GOTO 200
  476. IF (.NOT.FACET(LF3)) GOTO 200
  477. GOTO 210
  478. C
  479. 200 CONTINUE
  480. * write (6,*) ' soltet 3 invalide'
  481. C
  482. NFCMAX=NFCini
  483. CALL REPSUB(LF3)
  484. CALL REPSUB(LF2)
  485. CALL REPSUB(LF1)
  486. CALL REPSUB(IF3)
  487. goto 201
  488. C
  489. 210 CONTINUE
  490. C
  491. C MEMORISATION DU VOLUME IF3, JF2, KF1, LF1 ET LF2
  492. C ------------------------------------------------
  493. ICTV=ICTV+1
  494. NVOL=NVOL+1
  495. IF (NFV(1,IF3).EQ.0) NFV(1,IF2)=NVOL
  496. IF (NFV(1,IF3).NE.NVOL) NFV(2,IF2)=NVOL
  497. IF (NFV(1,lF1).EQ.0) NFV(1,lF1)=NVOL
  498. IF (NFV(1,lF1).NE.NVOL) NFV(2,lF1)=NVOL
  499. IF (NFV(1,lF2).EQ.0) NFV(1,lF2)=NVOL
  500. IF (NFV(1,lF2).NE.NVOL) NFV(2,lF2)=NVOL
  501. IF (NFV(1,lF3).EQ.0) NFV(1,lF3)=NVOL
  502. IF (NFV(1,lF3).NE.NVOL) NFV(2,lF3)=NVOL
  503. IVOL(9,NVOL)=25
  504. C
  505. DO 220 I=1,3
  506. IVOL(I,NVOL)=NFC(I,IF3)
  507. 220 CONTINUE
  508. IVOL(4,NVOL)=IP
  509. if (iimpi.eq.1) write (6,1240) nfacet,(ivol(i,nvol),i=1,4)
  510. 1240 FORMAT(' COM433-3 facettes ',i5,' TET4 ',4i5)
  511. C
  512. * DO 230 J=1,NPTMAX
  513. * WRITE(6,1250)J,(NPF(I,J),I=1,40)
  514. 1250 FORMAT(I4,4X,40I3)
  515. *230 CONTINUE
  516. C
  517. 201 continue
  518. if (nvol.eq.nvini) then
  519. nptmax=nptini
  520. return
  521. endif
  522. C
  523. * if (iimpi.ne.0) write (6,*) ' comm433 point ',nptmax
  524. IGAGNE=1
  525. RETURN
  526. C
  527. C FIN DE LA SUBROUTINE COM433
  528. END
  529.  
  530.  
  531.  
  532.  
  533.  

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