Télécharger pyra3.eso

Retour à la liste

Numérotation des lignes :

  1. C PYRA3 SOURCE JC220346 16/11/29 21:15:31 9221
  2. C---------------------------------------------------------------------|
  3. C |
  4. SUBROUTINE PYRA3(II,JJ,IF1,IF2,IGAGNE)
  5. C |
  6. C CETTE SUBROUTINE TENTE DE CREER DEUX PYRAMIDES 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,SOLPYR,SOLTET,DIAGO,IN2,VERDIV,IN
  18. C
  19. * WRITE(6,1000)
  20. 1000 FORMAT(' ----->>> PYRA3 <<<-----')
  21. C
  22. nptini=nptmax
  23. nfcini=nfcmax
  24. ICTF=0
  25. ICTV=0
  26. IP1=IPRED(IF1,II)
  27. IP2=IPRED(IF1,IP1)
  28. JP1=ISUCC(IF2,II)
  29. JP2=ISUCC(IF2,JP1)
  30. * CREATION POINT MILIEU
  31. NPTMAX=NPTMAX+1
  32. XYZ(4,NPTMAX)=(XYZ(4,IP1)+XYZ(4,IP2)+XYZ(4,JP1)+XYZ(4,JP2))/4.
  33. * deplacement du point pour l'eloigner de ii jj
  34. xn1=(xyz(2,jj)-xyz(2,ii))*((xyz(3,ip1)+xyz(3,ip2))/2-xyz(3,ii))-
  35. > (xyz(3,jj)-xyz(3,ii))*((xyz(2,ip1)+xyz(2,ip2))/2-xyz(2,ii))
  36. yn1=(xyz(3,jj)-xyz(3,ii))*((xyz(1,ip1)+xyz(1,ip2))/2-xyz(1,ii))-
  37. > (xyz(1,jj)-xyz(1,ii))*((xyz(3,ip1)+xyz(3,ip2))/2-xyz(3,ii))
  38. zn1=(xyz(1,jj)-xyz(1,ii))*((xyz(2,ip1)+xyz(2,ip2))/2-xyz(2,ii))-
  39. > (xyz(2,jj)-xyz(2,ii))*((xyz(1,ip1)+xyz(1,ip2))/2-xyz(1,ii))
  40. sn1=sqrt(xn1**2+yn1**2+zn1**2)
  41. xn1=xn1/sn1
  42. yn1=yn1/sn1
  43. zn1=zn1/sn1
  44. xn2=((xyz(2,jp1)+xyz(2,jp2))/2-xyz(2,ii))*(xyz(3,jj)-xyz(3,ii))-
  45. > ((xyz(3,jp1)+xyz(3,jp2))/2-xyz(3,ii))*(xyz(2,jj)-xyz(2,ii))
  46. yn2=((xyz(3,jp1)+xyz(3,jp2))/2-xyz(3,ii))*(xyz(1,jj)-xyz(1,ii))-
  47. > ((xyz(1,jp1)+xyz(1,jp2))/2-xyz(1,ii))*(xyz(3,jj)-xyz(3,ii))
  48. zn2=((xyz(1,jp1)+xyz(1,jp2))/2-xyz(1,ii))*(xyz(2,jj)-xyz(2,ii))-
  49. > ((xyz(2,jp1)+xyz(2,jp2))/2-xyz(2,ii))*(xyz(1,jj)-xyz(1,ii))
  50. sn2=sqrt(xn2**2+yn2**2+zn2**2)
  51. xn2=xn2/sn2
  52. yn2=yn2/sn2
  53. zn2=zn2/sn2
  54. xn=(xn1+xn2)/2
  55. yn=(yn1+yn2)/2
  56. zn=(zn1+zn2)/2
  57. sn=sqrt(xn**2+yn**2+zn**2)
  58. xn=xn/sn
  59. yn=yn/sn
  60. zn=zn/sn
  61. * xmil=(xyz(1,ii)+xyz(1,jj))/2
  62. * ymil=(xyz(2,ii)+xyz(2,jj))/2
  63. * zmil=(xyz(3,ii)+xyz(3,jj))/2
  64. *
  65. xv=xyz(1,jj)-xyz(1,ii)
  66. yv=xyz(2,jj)-xyz(2,ii)
  67. zv=xyz(3,jj)-xyz(3,ii)
  68. sv=sqrt(xv**2+yv**2+zv**2)
  69. xv=xv/sv
  70. yv=yv/sv
  71. zv=zv/sv
  72. xli1=xv*(xyz(1,ip1)-xyz(1,ii))+yv*(xyz(2,ip1)-xyz(2,ii))+
  73. > zv*(xyz(3,ip1)-xyz(3,ii))
  74. xli2=xv*(xyz(1,ip2)-xyz(1,ii))+yv*(xyz(2,ip2)-xyz(2,ii))+
  75. > zv*(xyz(3,ip2)-xyz(3,ii))
  76. xlj1=xv*(xyz(1,jp1)-xyz(1,ii))+yv*(xyz(2,jp1)-xyz(2,ii))+
  77. > zv*(xyz(3,jp1)-xyz(3,ii))
  78. xlj2=xv*(xyz(1,jp2)-xyz(1,ii))+yv*(xyz(2,jp2)-xyz(2,ii))+
  79. > zv*(xyz(3,jp2)-xyz(3,ii))
  80. xl=(xli1+xli2+xlj1+xlj2+2*sv+2*0)/8
  81. xl=0.5*sv
  82. xmil=xyz(1,ii)+xl*xv
  83. ymil=xyz(2,ii)+xl*yv
  84. zmil=xyz(3,ii)+xl*zv
  85. expf = xyz(4,nptmax)
  86. xyz(1,nptmax)=xmil+xn*expf*expfac
  87. xyz(2,nptmax)=ymil+yn*expf*expfac
  88. xyz(3,nptmax)=zmil+zn*expf*expfac
  89. * write (6,*) ' pyra3 creation de 2 elements et pt ',nptmax
  90. * write (6,*) (xyz(i,ii),i=1,4)
  91. * write (6,*) (xyz(i,jj),i=1,4)
  92. * write (6,*) (xyz(i,ip1),i=1,4)
  93. * write (6,*) (xyz(i,ip2),i=1,4)
  94. * write (6,*) (xyz(i,jp1),i=1,4)
  95. * write (6,*) (xyz(i,jp2),i=1,4)
  96. * write (6,*) (xyz(i,nptmax),i=1,4)
  97. * CREATION DES ELEMENTS
  98. IPTT=NPTMAX
  99. CALL DIST(iptt,nptaux,GL,IOK,ii,jj,ip1,ip2,jp1,jp2,0,0,0,0)
  100. IF (IOK.EQ.0) THEN
  101. NPTMAX=nptini
  102. IF (IVERB.EQ.1) WRITE (6,*) ' pyra3 DIST ',nptaux
  103. return
  104. ENDIF
  105. IF (gl.lt.xyz(4,iptt)/4) then
  106. IF (IVERB.EQ.1) write (6,*) 'pyra3 GL-1'
  107. nptmax=nptini
  108. return
  109. endif
  110. IF (.NOT.IN2(ii,IPTT,nfcini).or..NOT.IN2(jj,IPTT,nfcini)) THEN
  111. IF (IVERB.EQ.1) write (6,*) ' in2 echec '
  112. NPTMAX=nptini
  113. return
  114. ENDIF
  115. * creations des faces
  116. NFCMAX=NFCMAX+1
  117. IF3=NFCMAX
  118. NFC(1,IF3)=II
  119. NFC(2,IF3)=iptt
  120. NFC(3,IF3)=IP1
  121. NFC(4,IF3)=0
  122. *
  123. NFCMAX=NFCMAX+1
  124. IF4=NFCMAX
  125. NFC(1,IF4)=IP1
  126. NFC(2,IF4)=IPTT
  127. NFC(3,IF4)=IP2
  128. NFC(4,IF4)=0
  129. *
  130. NFCMAX=NFCMAX+1
  131. IF5=NFCMAX
  132. NFC(1,IF5)=IP2
  133. NFC(2,IF5)=IPTT
  134. NFC(3,IF5)=JJ
  135. NFC(4,IF5)=0
  136. * la face commune
  137. NFCMAX=NFCMAX+1
  138. IF6=NFCMAX
  139. NFC(1,IF6)=JJ
  140. NFC(2,IF6)=IPTT
  141. NFC(3,IF6)=II
  142. NFC(4,IF6)=0
  143. *
  144. NFCMAX=NFCMAX+1
  145. IF7=NFCMAX
  146. NFC(1,IF7)=JJ
  147. NFC(2,IF7)=iptt
  148. NFC(3,IF7)=jp2
  149. NFC(4,IF7)=0
  150. *
  151. NFCMAX=NFCMAX+1
  152. IF8=NFCMAX
  153. NFC(1,IF8)=jp2
  154. NFC(2,IF8)=iptt
  155. NFC(3,IF8)=jp1
  156. NFC(4,IF8)=0
  157. *
  158. NFCMAX=NFCMAX+1
  159. IF9=NFCMAX
  160. NFC(1,IF9)=jp1
  161. NFC(2,IF9)=iptt
  162. NFC(3,IF9)=II
  163. NFC(4,IF9)=0
  164. * si necessaire verification diago
  165. IF (DIAGO(iptt,ii,diacri)) GOTO 275
  166. IF (DIAGO(iptt,jj,diacri)) GOTO 275
  167. IF (DIAGO(iptt,ip1,diacri)) GOTO 275
  168. IF (DIAGO(iptt,ip2,diacri)) GOTO 275
  169. IF (DIAGO(iptt,jp1,diacri)) GOTO 275
  170. IF (DIAGO(iptt,jp2,diacri)) GOTO 275
  171. goto 276
  172. 275 continue
  173. nptmax=nptini
  174. nfcmax=nfcini
  175. IF (IVERB.EQ.1) write (6,*) ' pyra3 echec diago'
  176. return
  177. 276 continue
  178. C
  179. CALL REPSUB(IF1)
  180. CALL REPSUB(IF3)
  181. CALL REPSUB(IF4)
  182. CALL REPSUB(IF5)
  183. CALL REPSUB(IF6)
  184. * verification du premier element element
  185. IF (.NOT.SOLPYR(IF1,IF3,IF4,IF5,IF6)) then
  186. IF (IVERB.EQ.1) write (6,*) 'pyra3-1 solpyr invalide'
  187. GOTO 160
  188. endif
  189. IF (.NOT.FACET(IF3)) then
  190. IF (IVERB.EQ.1) write(6,*) ' pyra3 facet if3 invalide'
  191. GOTO 160
  192. ENDIF
  193. IF (.NOT.FACET(IF4)) then
  194. IF (IVERB.EQ.1) write(6,*) ' pyra3 facet if4 invalide'
  195. GOTO 160
  196. ENDIF
  197. IF (.NOT.FACET(IF5)) then
  198. IF (IVERB.EQ.1) write(6,*) ' pyra3 facet if5 invalide'
  199. GOTO 160
  200. ENDIF
  201. CALL REPSUB(IF2)
  202. CALL REPSUB(IF6)
  203. CALL REPSUB(IF7)
  204. CALL REPSUB(IF8)
  205. CALL REPSUB(IF9)
  206. * verification du deuxieme element element
  207. IF (.NOT.SOLPYR(IF2,IF6,IF7,IF8,IF9)) then
  208. IF (IVERB.EQ.1) write (6,*) 'pyra3-2 solpyr invalide'
  209. GOTO 165
  210. endif
  211. IF (.NOT.FACET(IF7)) then
  212. IF (IVERB.EQ.1) write(6,*) ' pyra3 facet if7 invalide'
  213. GOTO 165
  214. ENDIF
  215. IF (.NOT.FACET(IF8)) then
  216. IF (IVERB.EQ.1) write(6,*) ' pyra1 facet if8 invalide'
  217. GOTO 165
  218. ENDIF
  219. IF (.NOT.FACET(IF9)) then
  220. IF (IVERB.EQ.1) write(6,*) ' pyra1 facet if9 invalide'
  221. GOTO 165
  222. ENDIF
  223. * OK pour creation elements
  224. NVOL=NVOL+1
  225. IF (NFV(1,IF1).EQ.0) NFV(1,IF1)=NVOL
  226. IF (NFV(1,IF1).NE.NVOL) NFV(2,IF1)=NVOL
  227. IF (NFV(1,IF3).EQ.0) NFV(1,IF3)=NVOL
  228. IF (NFV(1,IF3).NE.NVOL) NFV(2,IF3)=NVOL
  229. IF (NFV(1,IF4).EQ.0) NFV(1,IF4)=NVOL
  230. IF (NFV(1,IF4).NE.NVOL) NFV(2,IF4)=NVOL
  231. IF (NFV(1,IF5).EQ.0) NFV(1,IF5)=NVOL
  232. IF (NFV(1,IF5).NE.NVOL) NFV(2,IF5)=NVOL
  233. IF (NFV(1,IF6).EQ.0) NFV(1,IF6)=NVOL
  234. IF (NFV(1,IF6).NE.NVOL) NFV(2,IF6)=NVOL
  235. IVOL(9,NVOL)=35
  236. DO 280 I=1,4
  237. IVOL(I,NVOL)=NFC(I,IF1)
  238. 280 CONTINUE
  239. IVOL(5,NVOL)=iptt
  240. if (iimpi.eq.1) write (6,1102) nfacet,(ivol(i,nvol),i=1,5)
  241. 1102 FORMAT(' PYRA3-1 facettes ',i5,' pyr5 ',8i5)
  242. NVOL=NVOL+1
  243. IVOL(9,NVOL)=35
  244. IF (NFV(1,IF2).EQ.0) NFV(1,IF2)=NVOL
  245. IF (NFV(1,IF2).NE.NVOL) NFV(2,IF2)=NVOL
  246. IF (NFV(1,IF6).EQ.0) NFV(1,IF6)=NVOL
  247. IF (NFV(1,IF6).NE.NVOL) NFV(2,IF6)=NVOL
  248. IF (NFV(1,IF7).EQ.0) NFV(1,IF7)=NVOL
  249. IF (NFV(1,IF7).NE.NVOL) NFV(2,IF7)=NVOL
  250. IF (NFV(1,IF8).EQ.0) NFV(1,IF8)=NVOL
  251. IF (NFV(1,IF8).NE.NVOL) NFV(2,IF8)=NVOL
  252. IF (NFV(1,IF9).EQ.0) NFV(1,IF9)=NVOL
  253. IF (NFV(1,IF9).NE.NVOL) NFV(2,IF9)=NVOL
  254. DO 282 I=1,4
  255. IVOL(I,NVOL)=NFC(I,IF2)
  256. 282 CONTINUE
  257. IVOL(5,NVOL)=iptt
  258. if (iimpi.eq.1) write (6,1101) nfacet,(ivol(i,nvol),i=1,5)
  259. 1101 FORMAT(' PYRA3-2 facettes ',i5,' pyr5 ',8i5)
  260. IGAGNE=1
  261. RETURN
  262. 165 continue
  263. CALL REPSUB(IF9)
  264. CALL REPSUB(IF8)
  265. CALL REPSUB(IF7)
  266. CALL REPSUB(IF6)
  267. CALL REPSUB(IF2)
  268. 160 continue
  269. CALL REPSUB(IF6)
  270. CALL REPSUB(IF5)
  271. CALL REPSUB(IF4)
  272. CALL REPSUB(IF3)
  273. CALL REPSUB(IF1)
  274. nptmax=nptini
  275. nfcmax=nfcini
  276. goto 9000
  277. 9000 CONTINUE
  278. END
  279.  
  280.  
  281.  
  282.  

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