Télécharger com444.eso

Retour à la liste

Numérotation des lignes :

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

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