Télécharger kprojf.eso

Retour à la liste

Numérotation des lignes :

  1. C KPROJF SOURCE CHAT 05/01/13 01:05:13 5004
  2. SUBROUTINE KPROJF(O1,A0,K1,K2
  3. * ,C,U2,SHC3D,SKCEL,SKBUFF,SPROJA,SPROGP)
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8 (A-H,O-Z)
  6. C----------------------------------------------------------------------
  7. C Calcul des facteurs de forme en 3D
  8. C Sp appele par FACGEN
  9. C PROJECTION DE LA FACE K2 PAR RAPPORT A UN POINT DE VUE PRIS
  10. C SUR LA FACE K1 (SP KPROJG)
  11. C ON DIVISE LA FACE K2 EN CAS D ERREUR ( SP KSUBDV)
  12. C
  13. C SP APPELE PAR KALFAC
  14. C
  15. C O1 : POINT DE VUE PRIS SUR K1
  16. C A0 : SOMMETS DU TRIANGLE DE LA FACE K2
  17. C K1 : INDICE DE LA PREMIERE FACE
  18. C K2 : INDICE DE LA DEUXIEME FACE
  19. C U2 : NORMALE A LA FACE K2
  20. C
  21. C NI LES POINTS NI LES ARETES N'ONT ETE PROJETES ANTERIEUREMENT
  22. C ON TRAITE LE NIVEAU 0 COMME LES SUIVANTS
  23. C
  24. C----------------------------------------------------------------------
  25. C
  26. DIMENSION O1(3),U2(4),A0(3,3)
  27. C TABLEAUX DE TRAVAIL
  28. DIMENSION AA0(3,3,4)
  29. DIMENSION A1(3,3),AA1(3,3,4)
  30. DIMENSION A2(3,3),AA2(3,3,4)
  31. DIMENSION A3(3,3),AA3(3,3,4)
  32. DIMENSION A4(3,3),AA4(3,3,4)
  33. DIMENSION A5(3,3),AA5(3,3,4)
  34. DIMENSION A6(3,3),AA6(3,3,4)
  35. DIMENSION BBB(3,3,1)
  36. C
  37. -INC TFFOR3D
  38. C
  39. C--------------------------------------------------------------
  40. SEGMENT SPROGP
  41. INTEGER KF(NPT),ICOO(2,NPT)
  42. REAL*8 XR(3,NPT)
  43. ENDSEGMENT
  44. C--------------------------------------------------------------
  45. SEGMENT SKCEL
  46. INTEGER KBCEL(NR,NR),IINT(2,NSTAC),IS(NSTAC),JS(NSTAC)
  47. REAL*8 RMAX
  48. ENDSEGMENT
  49. C
  50. C--------------------------------------------------------------------
  51. C
  52. C NIVEAU 0
  53. C --------
  54. C DEFINITION DE BBB
  55. C
  56. DO 11 K=1,3
  57. DO 12 I=1,3
  58. BBB(K,I,1) = A0(K,I)
  59. 12 CONTINUE
  60. 11 CONTINUE
  61.  
  62. NSUB = 1
  63. KSUB = 1
  64. CALL KSUBCR(O1,KSUB,NSUB,BBB,SHC3D,SPROGP,SPROJA)
  65.  
  66. NNF1 = KF(1)
  67. NNF2 = KF(2)
  68. NNF3 = KF(3)
  69. CALL KPROJG(K2,1,2,3,NNF1,NNF2,NNF3,1,2,3
  70. * ,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF,SPROGP,KERR)
  71.  
  72. IF (KERR.EQ.0) RETURN
  73. C WRITE(6,*) ' NIV 0 PB FACES ',K1,' ',K2,' KERR ',KERR,' KD ',KSUB
  74.  
  75.  
  76. C NIVEAU 1
  77. C --------
  78. CALL KSUBDV(A0,AA0,NSUB)
  79.  
  80. DO 100 KSUB = 1,NSUB
  81.  
  82. CALL KSUBCR(O1,KSUB,NSUB,AA0,SHC3D,SPROGP,SPROJA)
  83.  
  84. NNF1 = KF(1)
  85. NNF2 = KF(2)
  86. NNF3 = KF(3)
  87. CALL KPROJG(K2,1,2,3,NNF1,NNF2,NNF3,1,2,3
  88. * ,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF,SPROGP,KERR)
  89.  
  90. IF (KERR.EQ.0) GOTO 100
  91. C WRITE(6,*) ' NIV 1 PB FACES ',K1,' ',K2,' KERR ',KERR,' KD ',KSUB
  92.  
  93. C
  94. C NIVEAU 2
  95. C --------
  96. C
  97. C DEFIINITION DE A1
  98. C
  99. DO 110 K=1,3
  100. DO 111 I=1,3
  101. A1(K,I) = AA0(K,I,KSUB)
  102. 111 CONTINUE
  103. 110 CONTINUE
  104. C
  105. CALL KSUBDV(A1,AA1,NSUB2)
  106.  
  107. DO 200 KSUB2 = 1,NSUB2
  108.  
  109. CALL KSUBCR(O1,KSUB2,NSUB2,AA1,SHC3D,SPROGP,SPROJA)
  110.  
  111. NNF1 = KF(1)
  112. NNF2 = KF(2)
  113. NNF3 = KF(3)
  114. CALL KPROJG(K2,1,2,3,NNF1,NNF2,NNF3,1,2,3
  115. * ,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF,SPROGP,KERR)
  116.  
  117. IF (KERR.EQ.0) GOTO 200
  118. C WRITE(6,*) ' NIV 2 PB FACES ',K1,' ',K2,' KERR ',KERR,' KD ',KSUB2
  119.  
  120. C NIVEAU 3
  121. C --------
  122. C
  123. C DEFIINITION DE A2
  124. C
  125. DO 210 K=1,3
  126. DO 211 I=1,3
  127. A2(K,I) = AA1(K,I,KSUB2)
  128. 211 CONTINUE
  129. 210 CONTINUE
  130. C
  131. CALL KSUBDV(A2,AA2,NSUB3)
  132.  
  133. DO 300 KSUB3 = 1,NSUB3
  134.  
  135. CALL KSUBCR(O1,KSUB3,NSUB3,AA2,SHC3D,SPROGP,SPROJA)
  136.  
  137. NNF1 = KF(1)
  138. NNF2 = KF(2)
  139. NNF3 = KF(3)
  140. CALL KPROJG(K2,1,2,3,NNF1,NNF2,NNF3,1,2,3
  141. * ,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF,SPROGP,KERR)
  142.  
  143. IF (KERR.EQ.0) GOTO 300
  144. C WRITE(6,*) ' NIV 3 PB FACES ',K1,' ',K2,' KERR ',KERR,' KD ',KSUB3
  145.  
  146. C NIVEAU 4
  147. C --------
  148. C
  149. C DEFIINITION DE A3
  150. C
  151. DO 310 K=1,3
  152. DO 311 I=1,3
  153. A3(K,I) = AA2(K,I,KSUB3)
  154. 311 CONTINUE
  155. 310 CONTINUE
  156. C
  157. CALL KSUBDV(A3,AA3,NSUB4)
  158.  
  159. DO 400 KSUB4 = 1,NSUB4
  160.  
  161. CALL KSUBCR(O1,KSUB4,NSUB4,AA3,SHC3D,SPROGP,SPROJA)
  162.  
  163. NNF1 = KF(1)
  164. NNF2 = KF(2)
  165. NNF3 = KF(3)
  166. CALL KPROJG(K2,1,2,3,NNF1,NNF2,NNF3,1,2,3
  167. * ,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF,SPROGP,KERR)
  168.  
  169. IF (KERR.EQ.0) GOTO 400
  170. C WRITE(6,*) ' NIV 4 PB FACES ',K1,' ',K2,' KERR ',KERR,' KD ',KSUB4
  171.  
  172. C**
  173. C NIVEAU 5
  174. C --------
  175. C
  176. C DEFIINITION DE A4
  177. C
  178. DO 410 K=1,3
  179. DO 411 I=1,3
  180. A4(K,I) = AA3(K,I,KSUB4)
  181. 411 CONTINUE
  182. 410 CONTINUE
  183. C
  184. CALL KSUBDV(A4,AA4,NSUB5)
  185.  
  186. DO 500 KSUB5 = 1,NSUB5
  187.  
  188. CALL KSUBCR(O1,KSUB5,NSUB5,AA4,SHC3D,SPROGP,SPROJA)
  189.  
  190. NNF1 = KF(1)
  191. NNF2 = KF(2)
  192. NNF3 = KF(3)
  193. CALL KPROJG(K2,1,2,3,NNF1,NNF2,NNF3,1,2,3
  194. * ,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF,SPROGP,KERR)
  195.  
  196. IF (KERR.EQ.0) GOTO 500
  197. C WRITE(6,*) ' NIV 5 PB FACES ',K1,' ',K2,' KERR ',KERR,' KD ',KSUB5
  198.  
  199. C NIVEAU 6
  200. C --------
  201. C
  202. C DEFIINITION DE A5
  203. C
  204. DO 510 K=1,3
  205. DO 511 I=1,3
  206. A5(K,I) = AA4(K,I,KSUB4)
  207. 511 CONTINUE
  208. 510 CONTINUE
  209. C
  210. CALL KSUBDV(A5,AA5,NSUB6)
  211.  
  212. DO 600 KSUB6 = 1,NSUB6
  213.  
  214. CALL KSUBCR(O1,KSUB6,NSUB6,AA5,SHC3D,SPROGP,SPROJA)
  215.  
  216. NNF1 = KF(1)
  217. NNF2 = KF(2)
  218. NNF3 = KF(3)
  219. CALL KPROJG(K2,1,2,3,NNF1,NNF2,NNF3,1,2,3
  220. * ,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF,SPROGP,KERR)
  221.  
  222. IF (KERR.EQ.0) GOTO 600
  223. C WRITE(6,*) ' NIV 6 PB FACES ',K1,' ',K2,' KERR ',KERR,' KD ',KSUB5
  224.  
  225.  
  226. C NIVEAU 7
  227. C --------
  228. C
  229. C DEFIINITION DE A6
  230. C
  231. DO 610 K=1,3
  232. DO 611 I=1,3
  233. A6(K,I) = AA5(K,I,KSUB4)
  234. 611 CONTINUE
  235. 610 CONTINUE
  236. C
  237. CALL KSUBDV(A6,AA6,NSUB7)
  238.  
  239. DO 700 KSUB7 = 1,NSUB7
  240.  
  241. CALL KSUBCR(O1,KSUB7,NSUB7,AA6,SHC3D,SPROGP,SPROJA)
  242.  
  243. NNF1 = KF(1)
  244. NNF2 = KF(2)
  245. NNF3 = KF(3)
  246. CALL KPROJG(K2,1,2,3,NNF1,NNF2,NNF3,1,2,3
  247. * ,C,U2,SHC3D,SKCEL,SPROJA,SKBUFF,SPROGP,KERR)
  248.  
  249. IF (KERR.EQ.0) GOTO 700
  250. C WRITE(6,*) ' NIV 7 PB FACES ',K1,' ',K2,' KERR ',KERR,' KD ',KSUB5
  251. WRITE(6,900) K2,K1,KERR
  252. 900 FORMAT(1X,' LA FACE ',I4,' EST GRANDE OU TRES PROCHE DE LA FACE '
  253. $,I4,' NIVEAU D ERREUR ',I2)
  254.  
  255. C**
  256. 700 CONTINUE
  257. 600 CONTINUE
  258. 500 CONTINUE
  259. C**
  260. 400 CONTINUE
  261. 300 CONTINUE
  262. 200 CONTINUE
  263. 100 CONTINUE
  264. RETURN
  265. END
  266.  
  267.  
  268.  

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