Télécharger com444.eso

Retour à la liste

Numérotation des lignes :

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

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