Télécharger prism1.eso

Retour à la liste

Numérotation des lignes :

  1. C PRISM1 SOURCE JC220346 16/11/29 21:15:29 9221
  2. C---------------------------------------------------------------------|
  3. C |
  4. SUBROUTINE PRISM1(II,JJ,IF1,IF2,IGAGNE)
  5. C |
  6. C CETTE SUBROUTINE TENTE DE CREER UN PRISME 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,SOLPRI,SOLPYR,SOLTET,DIAGO,IN,PLAN
  18. C
  19. * WRITE(6,*) ' PRISM1 ',ii,jj,if1,if2
  20. C
  21. * write (6,*) ' liste des facettes restantes '
  22. * DO 444 I=1,NFCMAX
  23. * IF (IFAT(I).EQ.1) GOTO 444
  24. * WRITE (6,*) I,NFC(1,I),NFC(2,I),NFC(3,I),NFC(4,I)
  25. *444 CONTINUE
  26. N3=0
  27. N4=0
  28. N5=0
  29. ICTF=0
  30. ICTV=0
  31. C
  32. C RECHERCHE DE LA FACETTE IF3
  33. C ---------------------------
  34. C
  35. IF3=IFACE3(ISUCC(IF2,II),II,IPRED(IF1,II))
  36. * IF (IF3.NE.0) WRITE(6,1010)IF3
  37. 1010 FORMAT(' ** IF3=',I3)
  38. C
  39. IF (IF3.NE.0) THEN
  40. * si if3 dans le mauvais sens rien a faire
  41. if (isucc(if3,ii).ne.iPRED(IF1,II)) then
  42. IF (IVERB.EQ.1) write (6,*) ' prism1 face a l''envers if3 '
  43. return
  44. endif
  45. N3=1
  46. IF(NFC(4,IF3).NE.0) N3=2
  47. C FACE PAS TRIANGULAIRE
  48. ENDIF
  49. C
  50. C RECHERCHE DE LA FACETTE IF4
  51. C ---------------------------
  52. C
  53. IF4=IFACE3(IPRED(IF2,JJ),JJ,ISUCC(IF1,JJ))
  54. * IF (IF4.NE.0) WRITE(6,1020)IF4
  55. 1020 FORMAT(' ** IF4=',I3)
  56. C
  57. IF (IF4.NE.0) THEN
  58. * si if4 dans le mauvais sens rien a faire
  59. if (isucc(if4,jj).ne.iPRED(IF2,jj)) then
  60. IF (IVERB.EQ.1) write (6,*) ' prism1 face a l''envers if4 '
  61. return
  62. endif
  63. N4=1
  64. IF(NFC(4,IF4).NE.0) N4=2
  65. C FACE PAS TRIANGULAIRE
  66. ENDIF
  67. IF (N3.EQ.2.OR.N4.EQ.2) GOTO 9000
  68. C
  69. C
  70. C RECHERCHE DE LA FACETTE IF5
  71. C ---------------------------
  72. C
  73. IF5=IFACE4(ISUCC(IF1,JJ),IPRED(IF1,II),
  74. # ISUCC(IF2,II),IPRED(IF2,JJ))
  75. * IF (IF5.NE.0) WRITE(6,1030) IF5
  76. 1030 FORMAT(' **IF5=',I3)
  77. IF (IF5.LT.0) GOTO 9000
  78. IF (IF5.NE.0) N5=1
  79. C
  80. C
  81. IF (DIAGO(IPRED(IF1,II),ISUCC(IF2,II),0.95d0)) GOTO 9000
  82. * DIAGONALE QUADRILATERE
  83. C
  84. IF (DIAGO(IPRED(IF2,JJ),ISUCC(IF1,JJ),0.95d0)) GOTO 9000
  85. * DIAGONALE QUADRILATERE
  86. C
  87. C
  88. C CONSTRUCTION DU PRISME
  89. C ----------------------
  90. C
  91. IF (IF3.EQ.0) THEN
  92. C
  93. C CREATION DE LA FACETTE IF3
  94. C --------------------------
  95. NFCMAX=NFCMAX+1
  96. IF3=NFCMAX
  97. ICTF=ICTF+1
  98. C
  99. NFC(1,IF3)=IPRED(IF1,II)
  100. NFC(2,IF3)=II
  101. NFC(3,IF3)=ISUCC(IF2,II)
  102. NFC(4,IF3)=0
  103. C
  104. ENDIF
  105. C
  106. C
  107. IF (IF4.EQ.0) THEN
  108. C
  109. C CREATION DE LA FACETTE IF4
  110. C --------------------------
  111. NFCMAX=NFCMAX+1
  112. IF4=NFCMAX
  113. ICTF=ICTF+1
  114. C
  115. NFC(1,IF4)=JJ
  116. NFC(2,IF4)=ISUCC(IF1,JJ)
  117. NFC(3,IF4)=IPRED(IF2,JJ)
  118. NFC(4,IF4)=0
  119. C
  120. ENDIF
  121. C
  122. C
  123. IF (IF5.EQ.0) THEN
  124. C
  125. C CREATION DE LA FACETTE IF5
  126. C --------------------------
  127. NFCMAX=NFCMAX+1
  128. IF5=NFCMAX
  129. ICTF=ICTF+1
  130. C
  131. NFC(1,IF5)=IPRED(IF2,JJ)
  132. NFC(2,IF5)=ISUCC(IF1,JJ)
  133. NFC(3,IF5)=IPRED(IF1,II)
  134. NFC(4,IF5)=ISUCC(IF2,II)
  135. C
  136. C
  137. ENDIF
  138. C
  139. C ON ENLEVE LES FACETTES IF1, IF2 ET IF3
  140. C --------------------------------------
  141. CALL REPSUB(IF1)
  142. CALL REPSUB(IF2)
  143. CALL REPSUB(IF3)
  144. CALL REPSUB(IF4)
  145. CALL REPSUB(IF5)
  146. C
  147. C LE VOLUME CREE EST-IL VALIDE ?
  148. C ------------------------------
  149. IF (.NOT.PLAN(IF5)) GOTO 160
  150. IF (.NOT.FACET(IF3)) GOTO 160
  151. IF (.NOT.FACET(IF4)) GOTO 160
  152. IF (.NOT.FACET(IF5)) GOTO 160
  153. IF (.NOT.SOLPRI(IF1,IF2,IF3,IF4,IF5)) GOTO 160
  154. *
  155. * VERIFICATION TAILLE
  156. IF (N3.EQ.0.AND.N5.EQ.0) THEN
  157. KF1=IPRED(IF1,II)
  158. KF2=ISUCC(IF2,II)
  159. DNORM=(XYZ(1,KF1)-XYZ(1,KF2))**2
  160. # +(XYZ(2,KF1)-XYZ(2,KF2))**2
  161. # +(XYZ(3,KF1)-XYZ(3,KF2))**2
  162. DTEST=tcrit*XYZ(4,KF1)*XYZ(4,KF2)
  163. IF (DNORM.GT.DTEST) GOTO 160
  164. ENDIF
  165. IF (N4.EQ.0.AND.N5.EQ.0) THEN
  166. KF1=IPRED(IF2,JJ)
  167. KF2=ISUCC(IF1,JJ)
  168. DNORM=(XYZ(1,KF1)-XYZ(1,KF2))**2
  169. # +(XYZ(2,KF1)-XYZ(2,KF2))**2
  170. # +(XYZ(3,KF1)-XYZ(3,KF2))**2
  171. DTEST=tcrit*XYZ(4,KF1)*XYZ(4,KF2)
  172. IF (DNORM.GT.DTEST) GOTO 160
  173. ENDIF
  174. * verification complementaire sur la facette if5
  175. if (n5.eq.0) then
  176. do 200 i=1,4
  177. xyz(i,nptmax+1)=0.
  178. do 210 j=1,4
  179. xyz(i,nptmax+1)=xyz(i,nptmax+1)+xyz(i,nfc(j,if5))
  180. 210 continue
  181. xyz(i,nptmax+1)=xyz(i,nptmax+1)/4.d0
  182. 200 continue
  183. CALL DIST(nptmax+1,KP,GL,IOK,II,JJ,nfc(1,if5),nfc(2,if5),
  184. > nfc(3,if5),nfc(4,if5),0,0,0,0)
  185. if (iok.eq.0.AND.IVERB.EQ.1) write (6,*) ' prism1 echec dist'
  186. if (iok.eq.0) goto 160
  187. endif
  188. C
  189. C LE VOLUME CREE EST VALIDE |
  190. C ---------------------------
  191. C MEMORISATION DU VOLUME IF1, IF2, IF3, IF4 ET IF5
  192. C ------------------------------------------------
  193. NVOL=NVOL+1
  194. IVOL(9,NVOL)=30
  195. IF (NFV(1,IF1).EQ.0) NFV(1,IF1)=NVOL
  196. IF (NFV(1,IF1).NE.NVOL) NFV(2,IF1)=NVOL
  197. IF (NFV(1,IF2).EQ.0) NFV(1,IF2)=NVOL
  198. IF (NFV(1,IF2).NE.NVOL) NFV(2,IF2)=NVOL
  199. IF (NFV(1,IF3).EQ.0) NFV(1,IF3)=NVOL
  200. IF (NFV(1,IF3).NE.NVOL) NFV(2,IF3)=NVOL
  201. IF (NFV(1,IF4).EQ.0) NFV(1,IF4)=NVOL
  202. IF (NFV(1,IF4).NE.NVOL) NFV(2,IF4)=NVOL
  203. IF (NFV(1,IF5).EQ.0) NFV(1,IF5)=NVOL
  204. IF (NFV(1,IF5).NE.NVOL) NFV(2,IF5)=NVOL
  205. IVOL(1,NVOL)=II
  206. IVOL(2,NVOL)=IPRED(IF1,II)
  207. IVOL(3,NVOL)=ISUCC(IF2,II)
  208. IVOL(4,NVOL)=JJ
  209. IVOL(5,NVOL)=ISUCC(IF1,JJ)
  210. IVOL(6,NVOL)=IPRED(IF2,JJ)
  211. C
  212. * WRITE(6,1100)NVOL,(IVOL(I,NVOL),I=1,9)
  213. *1100 FORMAT(I4,4X,14I4)
  214. if (iimpi.eq.1) write (6,1100) nfacet,(ivol(i,nvol),i=1,6)
  215. 1100 FORMAT(' PRISM1 facettes ',i5,' pri6 ',8i5)
  216. C
  217. * DO 150 J=1,NPTMAX
  218. * WRITE(6,1110)J,(NPF(I,J),I=1,40)
  219. *1110 FORMAT(I4,4X,40I3)
  220. *150 CONTINUE
  221. C
  222. IGAGNE=1
  223. C
  224. RETURN
  225. C
  226. 160 CONTINUE
  227. C
  228. C LE VOLUME CREE N'EST PAS VALIDE: IL FAUT DONC DETRUIRE LES FACETT
  229. C CREEES. ---------------------------------------------------------
  230. CALL REPSUB(IF1)
  231. CALL REPSUB(IF2)
  232. CALL REPSUB(IF3)
  233. CALL REPSUB(IF4)
  234. CALL REPSUB(IF5)
  235. C
  236. NFCMAX=NFCMAX-ICTF
  237. C
  238. GOTO 9000
  239. 9000 CONTINUE
  240. * on va d'abord betement essayer de mettre 2 pyramides en rajoutant
  241. * un point
  242. call pyra3(II,JJ,IF1,IF2,IGAGNE)
  243. IF (IGAGNE.EQ.1) RETURN
  244. IF (N3.NE.0) CALL COMBL3(II,IF1,IF2,IF3,IGAGNE)
  245. IF (IGAGNE.EQ.1) RETURN
  246. IF (N4.NE.0) CALL COMBL3(JJ,IF2,IF1,IF4,IGAGNE)
  247. RETURN
  248. END
  249.  
  250.  
  251.  
  252.  
  253.  

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