Télécharger kdom8.eso

Retour à la liste

Numérotation des lignes :

  1. C KDOM8 SOURCE KK2000 14/04/10 21:15:14 8032
  2. SUBROUTINE KDOM8(NN1,NN2,NN3,NN4,NN5,NN6,NN7,NN8,NN9,NN10,
  3. & NN11,NN12,NN13,NN14,NN15,NN16,NN17,NN18,NN19,NN20,
  4. & NN21)
  5. C
  6. C************************************************************************
  7. C
  8. C PROJET : CASTEM 2000
  9. C
  10. C NOM : KDOM8
  11. C
  12. C DESCRIPTION : This subroutine check whether NN21 is inside of
  13. C the PR21
  14. C
  15. C LANGAGE : FORTRAN 77 + ESOPE 2000 (avec estensions CISI)
  16. C
  17. C AUTEUR : A. BECCANTINI, DRN/DMT/SEMT/LTMF
  18. C
  19. C************************************************************************
  20. C
  21. C
  22.  
  23. IMPLICIT INTEGER(I-N)
  24. IMPLICIT REAL*8(A-H,O-Z)
  25.  
  26. INTEGER NN1,NN2,NN3,NN4,NN5,NN6,NN7,NN8,NN9,NN10,
  27. & NN11,NN12,NN13,NN14,NN15,NN16,NN17,NN18,NN19,NN20,
  28. & NN21, I1, IPCEN, IPL, IPR
  29. REAL*8 DX0,DY0,DZ0,DX1,DY1,DZ1,NORX1,NORY1,NORZ1,PSCA0,PSCA1
  30. C
  31. -INC CCOPTIO
  32. -INC SMCOORD
  33. C
  34. C**** First triangle
  35. C
  36. IPCEN=NN1
  37. IPR=NN3
  38. IPL=NN5
  39. DX0=XCOOR((IPR-1)*(IDIM+1)+1)-
  40. & XCOOR((IPCEN-1)*(IDIM+1)+1)
  41. DY0=XCOOR((IPR-1)*(IDIM+1)+2)-
  42. & XCOOR((IPCEN-1)*(IDIM+1)+2)
  43. DZ0=XCOOR((IPR-1)*(IDIM+1)+3)-
  44. & XCOOR((IPCEN-1)*(IDIM+1)+3)
  45. DX1=XCOOR((IPL-1)*(IDIM+1)+1)-
  46. & XCOOR((IPCEN-1)*(IDIM+1)+1)
  47. DY1=XCOOR((IPL-1)*(IDIM+1)+2)-
  48. & XCOOR((IPCEN-1)*(IDIM+1)+2)
  49. DZ1=XCOOR((IPL-1)*(IDIM+1)+3)-
  50. & XCOOR((IPCEN-1)*(IDIM+1)+3)
  51. NORX1=(DY0*DZ1-DY1*DZ0)
  52. NORY1=(DZ0*DX1-DZ1*DX0)
  53. NORZ1=(DX0*DY1-DX1*DY0)
  54. C
  55. C The scalar product between this normal and
  56. C CENTRE-IPCEN
  57. C
  58. DX1=XCOOR((IPCEN-1)*(IDIM+1)+1)-
  59. & XCOOR((NN21-1)*(IDIM+1)+1)
  60. DY1=XCOOR((IPCEN-1)*(IDIM+1)+2)-
  61. & XCOOR((NN21-1)*(IDIM+1)+2)
  62. DZ1=XCOOR((IPCEN-1)*(IDIM+1)+3)-
  63. & XCOOR((NN21-1)*(IDIM+1)+3)
  64. PSCA0=DX1*NORX1+DY1*NORY1+DZ1*NORZ1
  65. C
  66. C The other triangles
  67. C
  68. DO I1=1,13
  69. IF(I1.EQ.1)THEN
  70. IPCEN=NN10
  71. IPR=NN14
  72. IPL=NN12
  73. ELSEIF(I1.EQ.2)THEN
  74. IPCEN=NN1
  75. IPR=NN18
  76. IPL=NN10
  77. ELSEIF(I1.EQ.3)THEN
  78. IPCEN=NN5
  79. IPR=NN18
  80. IPL=NN1
  81. ELSEIF(I1.EQ.4)THEN
  82. IPCEN=NN14
  83. IPR=NN18
  84. IPL=NN5
  85. ELSEIF(I1.EQ.5)THEN
  86. IPCEN=NN10
  87. IPR=NN18
  88. IPL=NN14
  89. ELSEIF(I1.EQ.6)THEN
  90. IPCEN=NN5
  91. IPR=NN17
  92. IPL=NN14
  93. ELSEIF(I1.EQ.7)THEN
  94. IPCEN=NN3
  95. IPR=NN17
  96. IPL=NN5
  97. ELSEIF(I1.EQ.8)THEN
  98. IPCEN=NN12
  99. IPR=NN17
  100. IPL=NN3
  101. ELSEIF(I1.EQ.9)THEN
  102. IPCEN=NN14
  103. IPR=NN17
  104. IPL=NN12
  105. ELSEIF(I1.EQ.10)THEN
  106. IPCEN=NN3
  107. IPR=NN16
  108. IPL=NN12
  109. ELSEIF(I1.EQ.11)THEN
  110. IPCEN=NN1
  111. IPR=NN16
  112. IPL=NN3
  113. ELSEIF(I1.EQ.12)THEN
  114. IPCEN=NN10
  115. IPR=NN16
  116. IPL=NN1
  117. ELSEIF(I1.EQ.13)THEN
  118. IPCEN=NN12
  119. IPR=NN16
  120. IPL=NN10
  121. ENDIF
  122. DX0=XCOOR((IPR-1)*(IDIM+1)+1)-
  123. & XCOOR((IPCEN-1)*(IDIM+1)+1)
  124. DY0=XCOOR((IPR-1)*(IDIM+1)+2)-
  125. & XCOOR((IPCEN-1)*(IDIM+1)+2)
  126. DZ0=XCOOR((IPR-1)*(IDIM+1)+3)-
  127. & XCOOR((IPCEN-1)*(IDIM+1)+3)
  128. DX1=XCOOR((IPL-1)*(IDIM+1)+1)-
  129. & XCOOR((IPCEN-1)*(IDIM+1)+1)
  130. DY1=XCOOR((IPL-1)*(IDIM+1)+2)-
  131. & XCOOR((IPCEN-1)*(IDIM+1)+2)
  132. DZ1=XCOOR((IPL-1)*(IDIM+1)+3)-
  133. & XCOOR((IPCEN-1)*(IDIM+1)+3)
  134. NORX1=(DY0*DZ1-DY1*DZ0)
  135. NORY1=(DZ0*DX1-DZ1*DX0)
  136. NORZ1=(DX0*DY1-DX1*DY0)
  137. C
  138. C The scalar product between this normal and
  139. C CENTRE-IPCEN
  140. C
  141. DX1=XCOOR((IPCEN-1)*(IDIM+1)+1)-
  142. & XCOOR((NN21-1)*(IDIM+1)+1)
  143. DY1=XCOOR((IPCEN-1)*(IDIM+1)+2)-
  144. & XCOOR((NN21-1)*(IDIM+1)+2)
  145. DZ1=XCOOR((IPCEN-1)*(IDIM+1)+3)-
  146. & XCOOR((NN21-1)*(IDIM+1)+3)
  147. PSCA1=DX1*NORX1+DY1*NORY1+DZ1*NORZ1
  148. IF((PSCA1*PSCA0) .LT.0)THEN
  149. C
  150. WRITE(IOIMP,*) 'Subroutine kdom8.eso'
  151. WRITE(IOIMP,*) 'PR21'
  152. C
  153. C Erreur -107 0
  154. C Liste des noeuds de l'élément :
  155. C
  156. CALL ERREUR(-107)
  157. WRITE(IOIMP,*) NN1,NN2,NN3,NN4,NN5,NN6,NN7,NN8,NN9,NN10
  158. WRITE(IOIMP,*) NN11,NN12,NN13,NN14,NN15,NN16,NN17,NN18,NN19
  159. $ ,NN20
  160. WRITE(IOIMP,*) NN21
  161. C
  162. C Erreur 845 2
  163. C Maillage donné incorrect ?!!!
  164. C
  165. CALL ERREUR(845)
  166. C
  167. GOTO 9999
  168. ENDIF
  169. ENDDO
  170. C
  171. 9999 RETURN
  172. END
  173.  
  174.  
  175.  
  176.  

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