Télécharger pyra1.eso

Retour à la liste

Numérotation des lignes :

  1. C PYRA1 SOURCE JC220346 16/11/29 21:15:30 9221
  2. C---------------------------------------------------------------------|
  3. C |
  4. SUBROUTINE PYRA1(II,JJ,IF1,IF2,IGAGNE,IBOUT)
  5. C |
  6. C CETTE SUBROUTINE TENTE DE CREER UNE PYRAMIDE A PARTIR |
  7. C DU TRIANGLE IF1 ET DU QUADRANGLE 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,SOLPYR,SOLTET,DIAGO,IN2,VERDIV,IN
  18. C
  19. * WRITE(6,1000)
  20. 1000 FORMAT(' ----->>> PYRA1 <<<-----')
  21. C
  22. * on se refuse a mailler une pyramide trop ouverte
  23. * if (TETA(IF1,IF2,II,JJ).lt.-100) goto 155
  24. nptini=nptmax
  25. nfcini=nfcmax
  26. ICTF=0
  27. ICTV=0
  28. N3=0
  29. N4=0
  30. N5=0
  31. ipin = 0
  32. * write (6,*) 'entree dans pyra1 ii jj if1 if2 ',ii,jj,if1,if2
  33. * write (6,*) ' liste des facettes '
  34. * DO 443 I=1,NFCMAX
  35. * IF (IFAT(I).EQ.1) GOTO 443
  36. * WRITE (6,*) I,NFC(1,I),NFC(2,I),NFC(3,I),NFC(4,I)
  37. *443 CONTINUE
  38. C
  39. C RECHERCHE D'UNE 3EME FACETTE IF3
  40. C --------------------------------
  41. IP1=IPRED(IF1,II)
  42. JP1=ISUCC(IF2,II)
  43. JP2=IPRED(IF2,JJ)
  44. *
  45. if (TETA(IF1,IF2,II,JJ).lt.-100) goto 250
  46. C
  47. IF3=IFACE3(IP1,II,JP1)
  48. C
  49. IF (IF3.NE.0) THEN
  50. * si if3 dans le mauvais sens rien a faire
  51. if (isucc(if3,ii).ne.ip1) then
  52. IF (IVERB.EQ.1) write (6,*) ' pyra1 face a l''envers if3 '
  53. return
  54. endif
  55. IF (NFC(4,IF3).NE.0) THEN
  56. CALL prism1(ii,jp1,IF2,IF3,IGAGNE)
  57. RETURN
  58. ENDIF
  59. * WRITE(6,1010)IF3
  60. 1010 FORMAT(' ** IF3=',I4)
  61. N3=IF3
  62. ENDIF
  63. C
  64. C
  65. C RECHERCHE D'UNE 4EME FACETTE IF4
  66. C --------------------------------
  67. C
  68. IF4=IFACE3(JJ,IP1,JP2)
  69. C
  70. IF (IF4.NE.0) THEN
  71. * si if4 dans le mauvais sens rien a faire
  72. if (isucc(if4,jj).ne.jp2) then
  73. IF (IVERB.EQ.1) write (6,*) ' pyra1 face a l''envers if4 '
  74. return
  75. endif
  76. IF (NFC(4,IF4).NE.0) THEN
  77. CALL prism1(jp2,jj,IF2,IF4,IGAGNE)
  78. RETURN
  79. ENDIF
  80. * WRITE(6,1020)IF4
  81. 1020 FORMAT(' ** IF4=',I4)
  82. N4=IF4
  83. ENDIF
  84. C
  85. C
  86. C RECHERCHE D'UNE 5EME FACETTE IF5
  87. C --------------------------------
  88. C
  89. IF5=IFACE3(JP1,JP2,IP1)
  90. C
  91. IF (IF5.NE.0) THEN
  92. * si if5 dans le mauvais sens rien a faire
  93. if (isucc(if5,jp2).ne.jp1) then
  94. IF (IVERB.EQ.1) write (6,*) ' pyra1 face a l''envers if5 '
  95. return
  96. endif
  97. IF (NFC(4,IF5).NE.0) GOTO 9000
  98. * WRITE(6,1030)IF5
  99. 1030 FORMAT(' ** IF5=',I4)
  100. N5=1
  101. ENDIF
  102. C
  103. * TEST LONGUEUR IP1 JP1 ET IP1 JP2
  104. IF (N3.EQ.0.AND.N5.EQ.0) THEN
  105. DNORM=(XYZ(1,IP1)-XYZ(1,JP1))**2
  106. # +(XYZ(2,IP1)-XYZ(2,JP1))**2
  107. # +(XYZ(3,IP1)-XYZ(3,JP1))**2
  108. DTEST= tetrl*XYZ(4,IP1)*XYZ(4,JP1)
  109. IF (DNORM.GT.DTEST) GOTO 250
  110. ENDIF
  111. IF (N4.EQ.0.AND.N5.EQ.0) THEN
  112. DNORM=(XYZ(1,IP1)-XYZ(1,JP2))**2
  113. # +(XYZ(2,IP1)-XYZ(2,JP2))**2
  114. # +(XYZ(3,IP1)-XYZ(3,JP2))**2
  115. DTEST= tetrl*XYZ(4,IP1)*XYZ(4,JP2)
  116. IF (DNORM.GT.DTEST) GOTO 260
  117. ENDIF
  118. IF (IF3.EQ.0.AND.IF5.EQ.0) THEN
  119. IF (DIAGO(IP1,JP1,diacri)) GOTO 9000
  120. ENDIF
  121. IF (IF4.EQ.0.AND.IF5.EQ.0) THEN
  122. IF (DIAGO(IP1,JP2,diacri)) GOTO 9000
  123. ENDIF
  124. C
  125. IF (IF3.EQ.0) THEN
  126. C
  127. C CREATION DE LA FACETTE IF3
  128. C --------------------------
  129. NFCMAX=NFCMAX+1
  130. IF3=NFCMAX
  131. ICTF=ICTF+1
  132. C
  133. NFC(1,IF3)=II
  134. NFC(2,IF3)=JP1
  135. NFC(3,IF3)=IP1
  136. NFC(4,IF3)=0
  137. C
  138. ENDIF
  139. C
  140. IF (IF4.EQ.0) THEN
  141. C
  142. C CREATION DE LA FACETTE IF4
  143. C --------------------------
  144. NFCMAX=NFCMAX+1
  145. IF4=NFCMAX
  146. ICTF=ICTF+1
  147. C
  148. NFC(1,IF4)=JJ
  149. NFC(2,IF4)=IP1
  150. NFC(3,IF4)=JP2
  151. NFC(4,IF4)=0
  152. C
  153. ENDIF
  154. C
  155. IF (IF5.EQ.0) THEN
  156. C
  157. C CREATION DE LA FACETTE IF5
  158. C --------------------------
  159. NFCMAX=NFCMAX+1
  160. IF5=NFCMAX
  161. ICTF=ICTF+1
  162. C
  163. NFC(1,IF5)=JP1
  164. NFC(2,IF5)=JP2
  165. NFC(3,IF5)=IP1
  166. NFC(4,IF5)=0
  167. C
  168. ENDIF
  169. C
  170. C
  171. C ON METS A JOUR LES FACETTES
  172. C ---------------------------
  173. CALL REPSUB(IF1)
  174. CALL REPSUB(IF2)
  175. CALL REPSUB(IF3)
  176. CALL REPSUB(IF4)
  177. CALL REPSUB(IF5)
  178. C
  179. C LE VOLUME CREE EST-IL VALIDE ?
  180. C ------------------------------
  181. IF (N3.EQ.0) THEN
  182. IF (.NOT.FACET(IF3)) GOTO 190
  183. ENDIF
  184. IF (N4.EQ.0) THEN
  185. IF (.NOT.FACET(IF4)) GOTO 190
  186. ENDIF
  187. IF (N5.EQ.0) THEN
  188. IF (.NOT.FACET(IF5)) GOTO 190
  189. ENDIF
  190. IF (.NOT.SOLPYR(IF2,IF1,IF3,IF4,IF5)) GOTO 190
  191. * test des points milieux
  192. if (n3.eq.0.and.n5.eq.0) then
  193. DO 242 I=1,4
  194. XYZ(I,NPTMAX+1)=(XYZ(4,JP1)*XYZ(I,IP1)+XYZ(4,IP1)*XYZ(I,JP1))/
  195. # (XYZ(4,JP1)+XYZ(4,IP1))
  196. 242 CONTINUE
  197. XYZ(4,NPTMAX+1)=SQRT(XYZ(4,IP1)*XYZ(4,JP1))
  198. CALL DIST(nptmax+1,nptaux,GL,IOK,II,JJ,IP1,JP1,JP2,0,0,0,0,0)
  199. IF (IOK.EQ.0) then
  200. IF (IVERB.EQ.1) write (6,*) ' pyra1 DIST-1 echoue'
  201. goto 190
  202. endif
  203. IF (gl.lt.xyz(4,nptmax+1)/4) then
  204. IF (IVERB.EQ.1) write (6,*) ' pyra1 DIST-1-GL echoue'
  205. goto 190
  206. endif
  207. endif
  208. if (n4.eq.0.and.n5.eq.0) then
  209. DO 243 I=1,4
  210. XYZ(I,NPTMAX+1)=(XYZ(4,JP2)*XYZ(I,IP1)+XYZ(4,IP1)*XYZ(I,JP2))/
  211. # (XYZ(4,JP2)+XYZ(4,IP1))
  212. 243 CONTINUE
  213. XYZ(4,NPTMAX+1)=SQRT(XYZ(4,IP1)*XYZ(4,JP2))
  214. CALL DIST(nptmax+1,nptaux,GL,IOK,II,JJ,IP1,JP1,JP2,0,0,0,0,0)
  215. IF (IOK.EQ.0) then
  216. IF (IVERB.EQ.1) write (6,*) ' pyra1 DIST-2 echoue'
  217. goto 190
  218. endif
  219. IF (gl.lt.xyz(4,nptmax+1)/4) then
  220. IF (IVERB.EQ.1) write (6,*) ' pyra1 DIST-2-GL echoue'
  221. goto 190
  222. endif
  223. endif
  224. *
  225. C
  226. C LE VOLUME CREE EST VALIDE
  227. C -------------------------
  228. C MEMORISATION DU VOLUME OBTENU
  229. C -----------------------------
  230. NVOL=NVOL+1
  231. IF (NFV(1,IF1).EQ.0) NFV(1,IF1)=NVOL
  232. IF (NFV(1,IF1).NE.NVOL) NFV(2,IF1)=NVOL
  233. IF (NFV(1,IF2).EQ.0) NFV(1,IF2)=NVOL
  234. IF (NFV(1,IF2).NE.NVOL) NFV(2,IF2)=NVOL
  235. IF (NFV(1,IF3).EQ.0) NFV(1,IF3)=NVOL
  236. IF (NFV(1,IF3).NE.NVOL) NFV(2,IF3)=NVOL
  237. IF (NFV(1,IF4).EQ.0) NFV(1,IF4)=NVOL
  238. IF (NFV(1,IF4).NE.NVOL) NFV(2,IF4)=NVOL
  239. IF (NFV(1,IF5).EQ.0) NFV(1,IF5)=NVOL
  240. IF (NFV(1,IF5).NE.NVOL) NFV(2,IF5)=NVOL
  241. IVOL(9,NVOL)=35
  242. DO 170 I=1,4
  243. IVOL(I,NVOL)=NFC(I,IF2)
  244. 170 CONTINUE
  245. IVOL(5,NVOL)=IP1
  246. C
  247. * WRITE(6,1100)NVOL,(IVOL(I,NVOL),I=1,9)
  248. *1100 FORMAT(I3,4X,14I4)
  249. if (iimpi.eq.1) write (6,1100) nfacet,(ivol(i,nvol),i=1,5)
  250. 1100 FORMAT(' PYRA1 facettes ',i5,' pyr5 ',5i5)
  251. C
  252. * DO 180 J=1,NPTMAX
  253. * WRITE(6,1110)J,(NPF(I,J),I=1,40)
  254. *1110 FORMAT(I4,4X,40I3)
  255. *180 CONTINUE
  256. C
  257. C
  258. IGAGNE=1
  259. C
  260. RETURN
  261. C
  262. 190 CONTINUE
  263. C
  264. C LE VOLUME CREE EST INVALIDE: IL FAUT DONC DETRUIRE LES FACETTES
  265. C CREES. --------------------------------------------------------
  266. CALL REPSUB(IF1)
  267. CALL REPSUB(IF2)
  268. CALL REPSUB(IF3)
  269. CALL REPSUB(IF4)
  270. CALL REPSUB(IF5)
  271. C
  272. NFCMAX=NFCMAX-ICTF
  273. C
  274. GOTO 9000
  275. C
  276. 9000 CONTINUE
  277. IF (IBOUT.EQ.1) RETURN
  278. IF (N3.NE.0) CALL COMBL3(II,IF1,IF2,N3,IGAGNE)
  279. IF (IGAGNE.EQ.1) RETURN
  280. IF (N4.NE.0) CALL COMBL3(JJ,IF2,IF1,N4,IGAGNE)
  281. RETURN
  282. 250 CONTINUE
  283. 260 CONTINUE
  284. * CREATION POINT MILIEU
  285. NPTMAX=NPTMAX+1
  286. XYZ(4,NPTMAX)=(XYZ(4,IP1)+XYZ(4,JP1)+XYZ(4,JP2))/3.
  287. * deplacement du point pour l'eloigner de ii jj
  288. xn1=(xyz(2,jj)-xyz(2,ii))*(xyz(3,ip1)-xyz(3,ii))-
  289. > (xyz(3,jj)-xyz(3,ii))*(xyz(2,ip1)-xyz(2,ii))
  290. yn1=(xyz(3,jj)-xyz(3,ii))*(xyz(1,ip1)-xyz(1,ii))-
  291. > (xyz(1,jj)-xyz(1,ii))*(xyz(3,ip1)-xyz(3,ii))
  292. zn1=(xyz(1,jj)-xyz(1,ii))*(xyz(2,ip1)-xyz(2,ii))-
  293. > (xyz(2,jj)-xyz(2,ii))*(xyz(1,ip1)-xyz(1,ii))
  294. * scal=xn1*(xyz(1,jp1)-xyz(1,ii))+xn2*(xyz(2,jp1)-xyz(2,ii))+
  295. * > xn3*(xyz(3,jp1)-xyz(3,ii))
  296. * write (6,*) ' dnas tetra scal ',scal
  297. * write (6,*) ' ii ',(XYZ(i,ii),i=1,4)
  298. * write (6,*) ' jj ',(XYZ(i,jj),i=1,4)
  299. * write (6,*) ' ip ',(XYZ(i,ip),i=1,4)
  300. * write (6,*) ' jp ',(XYZ(i,jp),i=1,4)
  301. * write (6,*) ' xn ',xn1,yn1,zn1
  302. sn1=sqrt(xn1**2+yn1**2+zn1**2)
  303. xn1=xn1/sn1
  304. yn1=yn1/sn1
  305. zn1=zn1/sn1
  306. xn2=((xyz(2,jp1)+xyz(2,jp2))/2-xyz(2,ii))*(xyz(3,jj)-xyz(3,ii))-
  307. > ((xyz(3,jp1)+xyz(3,jp2))/2-xyz(3,ii))*(xyz(2,jj)-xyz(2,ii))
  308. yn2=((xyz(3,jp1)+xyz(3,jp2))/2-xyz(3,ii))*(xyz(1,jj)-xyz(1,ii))-
  309. > ((xyz(1,jp1)+xyz(1,jp2))/2-xyz(1,ii))*(xyz(3,jj)-xyz(3,ii))
  310. zn2=((xyz(1,jp1)+xyz(1,jp2))/2-xyz(1,ii))*(xyz(2,jj)-xyz(2,ii))-
  311. > ((xyz(2,jp1)+xyz(2,jp2))/2-xyz(2,ii))*(xyz(1,jj)-xyz(1,ii))
  312. sn2=sqrt(xn2**2+yn2**2+zn2**2)
  313. xn2=xn2/sn2
  314. yn2=yn2/sn2
  315. zn2=zn2/sn2
  316. xn=(xn1+xn2)/2
  317. yn=(yn1+yn2)/2
  318. zn=(zn1+zn2)/2
  319. sn=sqrt(xn**2+yn**2+zn**2)
  320. xn=xn/sn
  321. yn=yn/sn
  322. zn=zn/sn
  323. * xmil=(xyz(1,ii)+xyz(1,jj))/2
  324. * ymil=(xyz(2,ii)+xyz(2,jj))/2
  325. * zmil=(xyz(3,ii)+xyz(3,jj))/2
  326. *
  327. xv=xyz(1,jj)-xyz(1,ii)
  328. yv=xyz(2,jj)-xyz(2,ii)
  329. zv=xyz(3,jj)-xyz(3,ii)
  330. sv=sqrt(xv**2+yv**2+zv**2)
  331. xv=xv/sv
  332. yv=yv/sv
  333. zv=zv/sv
  334. xli=xv*(xyz(1,ip1)-xyz(1,ii))+yv*(xyz(2,ip1)-xyz(2,ii))+
  335. > zv*(xyz(3,ip1)-xyz(3,ii))
  336. xlj1=xv*(xyz(1,jp1)-xyz(1,ii))+yv*(xyz(2,jp1)-xyz(2,ii))+
  337. > zv*(xyz(3,jp1)-xyz(3,ii))
  338. xlj2=xv*(xyz(1,jp2)-xyz(1,ii))+yv*(xyz(2,jp2)-xyz(2,ii))+
  339. > zv*(xyz(3,jp2)-xyz(3,ii))
  340. xl=(xli+xlj1+xlj2+2*sv+2*0)/7
  341. xl=0.5*sv
  342. xmil=xyz(1,ii)+xl*xv
  343. ymil=xyz(2,ii)+xl*yv
  344. zmil=xyz(3,ii)+xl*zv
  345. expf = xyz(4,nptmax)
  346. xyz(1,nptmax)=xmil+xn*expf*expfac
  347. xyz(2,nptmax)=ymil+yn*expf*expfac
  348. xyz(3,nptmax)=zmil+zn*expf*expfac
  349. * write (6,*) ' pyra1 creation de 2 elements et pt ',nptmax
  350. * write (6,*) ' coordonnees ',(XYZ(i,nptmax),i=1,4)
  351. * write (6,*) ' coordonnees ',(XYZ(i,ip),i=1,4)
  352. * write (6,*) ' coordonnees ',(XYZ(i,jp),i=1,4)
  353. * write (6,*) ' coordonnees ',xmil,ymil,zmil
  354. * CREATION DES ELEMENTS
  355. IPTT=NPTMAX
  356. CALL DIST(iptt,nptaux,GL,IOK,ii,jj,ip1,jp1,jp2,0,0,0,0,0)
  357. IF (IOK.EQ.0) THEN
  358. NPTMAX=nptini
  359. IF (IVERB.EQ.1) WRITE (6,*) ' pyra1 DIST ',nptaux
  360. * if (nptaux.eq.0) goto 9000
  361. return
  362. iptt=nptaux
  363. ENDIF
  364. IF (gl.lt.xyz(4,iptt)/4) then
  365. IF (IVERB.EQ.1) write (6,*) 'pyra1 GL-1'
  366. nptmax=nptini
  367. return
  368. endif
  369. 253 continue
  370. IF (.NOT.IN2(ii,IPTT,nfcini).or..NOT.IN2(jj,IPTT,nfcini)) THEN
  371. NPTMAX=nptini
  372. goto 9000
  373. ENDIF
  374. * recherche existence de la face
  375. IF3=IFACE3(ii,iptt,ip1)
  376. IF (IF3.ne.0.AND.IVERB.EQ.1)
  377. & write (6,*) ' pyra1 facette assimilee'
  378. IF (IF3.eq.0) THEN
  379. NFCMAX=NFCMAX+1
  380. IF3=NFCMAX
  381. NFC(1,IF3)=II
  382. NFC(2,IF3)=iptt
  383. NFC(3,IF3)=IP1
  384. NFC(4,IF3)=0
  385. elseif (NFC(4,if3).ne.0.or.ipred(if3,ii).ne.iptt) then
  386. IF (IVERB.EQ.1) write(6,*) ' pyra1 probleme facette if3 ',if3
  387. nptmax=nptini
  388. nfcmax=nfcini
  389. goto 9000
  390. endif
  391. * recherche existence de la face
  392. IF4=IFACE3(ii,jp1,iptt)
  393. IF (IF4.ne.0.AND.IVERB.EQ.1)
  394. & write (6,*) ' pyra1 facette assimilee'
  395. IF (IF4.eq.0) THEN
  396. NFCMAX=NFCMAX+1
  397. IF4=NFCMAX
  398. NFC(1,IF4)=II
  399. NFC(2,IF4)=JP1
  400. NFC(3,IF4)=iptt
  401. NFC(4,IF4)=0
  402. elseif (NFC(4,if4).ne.0.or.ipred(if4,ii).ne.jp1) then
  403. IF (IVERB.EQ.1) write(6,*) ' pyra1 probleme facette if4 ',if4
  404. nptmax=nptini
  405. nfcmax=nfcini
  406. goto 9000
  407. endif
  408. * recherche existence de la face
  409. IF5=IFACE3(jp1,jp2,iptt)
  410. IF (IF5.ne.0.AND.IVERB.EQ.1)
  411. & write (6,*) ' pyra1 facette assimilee'
  412. IF (IF5.eq.0) THEN
  413. NFCMAX=NFCMAX+1
  414. IF5=NFCMAX
  415. NFC(1,IF5)=JP1
  416. NFC(2,IF5)=JP2
  417. NFC(3,IF5)=iptt
  418. NFC(4,IF5)=0
  419. elseif (NFC(4,if5).ne.0.or.ipred(if5,jp1).ne.jp2) then
  420. IF (IVERB.EQ.1) write(6,*) ' pyra1 probleme facette if5 ',if5
  421. nptmax=nptini
  422. nfcmax=nfcini
  423. goto 9000
  424. endif
  425. * recherche existence de la face
  426. IF6=IFACE3(jp2,jj,iptt)
  427. IF (IF6.ne.0.AND.IVERB.EQ.1)
  428. & write (6,*) ' pyra1 facette assimilee'
  429. IF (IF6.eq.0) THEN
  430. NFCMAX=NFCMAX+1
  431. IF6=NFCMAX
  432. NFC(1,IF6)=JP2
  433. NFC(2,IF6)=JJ
  434. NFC(3,IF6)=iptt
  435. NFC(4,IF6)=0
  436. elseif (NFC(4,if6).ne.0.or.ipred(if6,jp2).ne.jj) then
  437. IF (IVERB.EQ.1) write(6,*) ' pyra1 probleme facette if6 ',if6
  438. nptmax=nptini
  439. nfcmax=nfcini
  440. goto 9000
  441. endif
  442. * recherche existence de la face
  443. IF7=IFACE3(jj,ip1,iptt)
  444. IF (IF7.ne.0.AND.IVERB.EQ.1)
  445. & write (6,*) ' pyra1 facette assimilee'
  446. IF (IF7.eq.0) THEN
  447. NFCMAX=NFCMAX+1
  448. IF7=NFCMAX
  449. NFC(1,IF7)=JJ
  450. NFC(2,IF7)=IP1
  451. NFC(3,IF7)=iptt
  452. NFC(4,IF7)=0
  453. elseif (NFC(4,if7).ne.0.or.ipred(if7,jj).ne.ip1) then
  454. IF (IVERB.EQ.1) write(6,*) ' pyra1 probleme facette if7 ',if7
  455. nptmax=nptini
  456. nfcmax=nfcini
  457. goto 9000
  458. endif
  459. * creation facette commune (necessaire pour faire les verification)
  460. IF8=IFACE3(ii,jj,iptt)
  461. IF (IF8.ne.0.AND.IVERB.EQ.1)
  462. & write(6,*)' pyra1 facette if8 existe deja => echec'
  463. IF (IF8.ne.0) THEN
  464. nptmax=nptini
  465. nfcmax=nfcini
  466. goto 9000
  467. endif
  468. NFCMAX=NFCMAX+1
  469. IF8=NFCMAX
  470. NFC(1,IF8)=ii
  471. NFC(2,IF8)=jj
  472. NFC(3,IF8)=iptt
  473. NFC(4,IF8)=0
  474. * si necessaire verification diago
  475. * if (nptini.eq.nptmax) then
  476. IF (DIAGO(iptt,ii,diacri)) GOTO 275
  477. IF (DIAGO(iptt,jj,diacri)) GOTO 275
  478. IF (DIAGO(iptt,ip1,diacri)) GOTO 275
  479. IF (DIAGO(iptt,jp1,diacri)) GOTO 275
  480. IF (DIAGO(iptt,jp2,diacri)) GOTO 275
  481. goto 276
  482. 275 continue
  483. nptmax=nptini
  484. nfcmax=nfcini
  485. goto 9000
  486. 276 continue
  487. * endif
  488. C
  489. CALL REPSUB(IF1)
  490. CALL REPSUB(IF3)
  491. CALL REPSUB(IF7)
  492. CALL REPSUB(IF8)
  493. * verification du premier element element
  494. IF (.NOT.SOLTET(IF1,IF3,IF7,IF8,ipin)) then
  495. IF (IVERB.EQ.1) write (6,*) 'pyra1 soltet invalide'
  496. GOTO 160
  497. endif
  498. IF (.NOT.FACET(IF3)) then
  499. IF (IVERB.EQ.1) write(6,*) ' pyra1 facet if3 invalide'
  500. GOTO 160
  501. ENDIF
  502. IF (.NOT.FACET(IF7)) then
  503. IF (IVERB.EQ.1) write(6,*) ' pyra1 facet if7 invalide'
  504. GOTO 160
  505. ENDIF
  506. CALL REPSUB(IF2)
  507. CALL REPSUB(IF4)
  508. CALL REPSUB(IF5)
  509. CALL REPSUB(IF6)
  510. CALL REPSUB(IF8)
  511. * verification du deuxieme element element
  512. IF (.NOT.SOLPYR(IF2,IF4,IF5,IF6,IF8)) then
  513. IF (IVERB.EQ.1) write (6,*) 'pyra1 solpyr invalide'
  514. GOTO 165
  515. endif
  516. IF (.NOT.FACET(IF4)) then
  517. IF (IVERB.EQ.1) write(6,*) ' pyra1 facet if4 invalide'
  518. GOTO 165
  519. ENDIF
  520. IF (.NOT.FACET(IF5)) then
  521. IF (IVERB.EQ.1) write(6,*) ' pyra1 facet if5 invalide'
  522. GOTO 165
  523. ENDIF
  524. IF (.NOT.FACET(IF6)) then
  525. IF (IVERB.EQ.1) write(6,*) ' pyra1 facet if6 invalide'
  526. GOTO 165
  527. ENDIF
  528. * OK pour creation elements
  529. NVOL=NVOL+1
  530. IF (NFV(1,IF1).EQ.0) NFV(1,IF1)=NVOL
  531. IF (NFV(1,IF1).NE.NVOL) NFV(2,IF1)=NVOL
  532. IF (NFV(1,IF3).EQ.0) NFV(1,IF3)=NVOL
  533. IF (NFV(1,IF3).NE.NVOL) NFV(2,IF3)=NVOL
  534. IF (NFV(1,IF4).EQ.0) NFV(1,IF4)=NVOL
  535. IF (NFV(1,IF4).NE.NVOL) NFV(2,IF4)=NVOL
  536. IF (NFV(1,IF5).EQ.0) NFV(1,IF5)=NVOL
  537. IF (NFV(1,IF5).NE.NVOL) NFV(2,IF5)=NVOL
  538. IVOL(9,NVOL)=35
  539. DO 280 I=1,4
  540. IVOL(I,NVOL)=NFC(I,IF2)
  541. 280 CONTINUE
  542. IVOL(5,NVOL)=iptt
  543. if (iimpi.eq.1) write (6,1102) nfacet,(ivol(i,nvol),i=1,5)
  544. 1102 FORMAT(' PYRA1-1 facettes ',i5,' pyr5 ',8i5)
  545. NVOL=NVOL+1
  546. IVOL(9,NVOL)=25
  547. IF (NFV(1,IF2).EQ.0) NFV(1,IF2)=NVOL
  548. IF (NFV(1,IF2).NE.NVOL) NFV(2,IF2)=NVOL
  549. IF (NFV(1,IF6).EQ.0) NFV(1,IF6)=NVOL
  550. IF (NFV(1,IF6).NE.NVOL) NFV(2,IF6)=NVOL
  551. IF (NFV(1,IF7).EQ.0) NFV(1,IF7)=NVOL
  552. IF (NFV(1,IF7).NE.NVOL) NFV(2,IF7)=NVOL
  553. DO 282 I=1,3
  554. IVOL(I,NVOL)=NFC(I,IF1)
  555. 282 CONTINUE
  556. IVOL(4,NVOL)=iptt
  557. if (iimpi.eq.1) write (6,1101) nfacet,(ivol(i,nvol),i=1,4)
  558. 1101 FORMAT(' PYRA1-2 facettes ',i5,' tet4 ',8i5)
  559. * write (6,*) ' pyra1 2 elements fabriques '
  560. * write (6,*) ' liste des facettes '
  561. * DO 444 I=1,NFCMAX
  562. * IF (IFAT(I).EQ.1) GOTO 444
  563. * WRITE (6,*) I,NFC(1,I),NFC(2,I),NFC(3,I),NFC(4,I)
  564. *444 CONTINUE
  565. IGAGNE=1
  566. RETURN
  567. 165 continue
  568. CALL REPSUB(IF8)
  569. CALL REPSUB(IF6)
  570. CALL REPSUB(IF5)
  571. CALL REPSUB(IF4)
  572. CALL REPSUB(IF2)
  573. 160 continue
  574. CALL REPSUB(IF8)
  575. CALL REPSUB(IF7)
  576. CALL REPSUB(IF3)
  577. CALL REPSUB(IF1)
  578. nptmax=nptini
  579. nfcmax=nfcini
  580. goto 9000
  581.  
  582. END
  583.  
  584.  
  585.  
  586.  
  587.  

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