Télécharger sorstl.eso

Retour à la liste

Numérotation des lignes :

  1. C SORSTL SOURCE JC220346 18/12/04 21:16:22 9991
  2. SUBROUTINE SORSTL
  3.  
  4. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  5. C
  6. C But : Ecrire un maillage sous forme d'un fichier ASCII
  7. C STL
  8. C
  9. C Auteur : CB215821
  10. C
  11. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  12. IMPLICIT REAL*8 (A-H,O-Z)
  13. IMPLICIT INTEGER(I-N)
  14.  
  15.  
  16. -INC PPARAM
  17. -INC CCOPTIO
  18. -INC CCNOYAU
  19. -INC CCGEOME
  20. -INC SMCOORD
  21. -INC SMELEME
  22.  
  23. CHARACTER*4 COLO4
  24. CHARACTER*(LONOM) CHNOM
  25.  
  26. ITRI3 = 0
  27. COLO4 = 'TRI3'
  28. CHNOM = ' '
  29. CALL PLACE(NOMS,NOMBR,ITRI3,COLO4)
  30.  
  31. C ... Si le fichier existe deja, on va l'ecraser ...
  32. REWIND IOPER
  33.  
  34.  
  35. CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
  36. IF(IERR .NE. 0) RETURN
  37.  
  38. C Lecture du nom du dernier objet lu
  39. CALL QUENOM(CHNOM)
  40.  
  41. SEGACT,MELEME
  42. NBSOUS=MELEME.LISOUS(/1)
  43.  
  44. IF(NBSOUS .NE. 0)THEN
  45. SEGDES,MELEME
  46. CALL ERREUR(21)
  47. RETURN
  48. ELSE
  49. IF(ITYPEL .NE. ITRI3)THEN
  50. SEGDES,MELEME
  51. CALL ERREUR(16)
  52. RETURN
  53. ENDIF
  54. ENDIF
  55.  
  56. NBELEM=MELEME.NUM(/2)
  57. IF (NBELEM .EQ. 0) THEN
  58. CALL ERREUR(21)
  59. RETURN
  60. ENDIF
  61.  
  62. IF (IDIM .NE. 3) THEN
  63. INTERR(1)=IDIM
  64. CALL ERREUR(709)
  65. RETURN
  66. ENDIF
  67.  
  68. C Specification des differents FORMATS ASCII a sortir
  69. 1201 FORMAT('solid ',A)
  70. 1202 FORMAT('facet normal ',ES13.5,1X,ES13.5,1X,ES13.5)
  71. 1203 FORMAT('outer loop')
  72. 1204 FORMAT('vertex ',ES13.5,1X,ES13.5,1X,ES13.5)
  73. 1205 FORMAT('endloop')
  74. 1206 FORMAT('endfacet')
  75. 1207 FORMAT('endsolid ', A)
  76.  
  77.  
  78. C Debut de l'ecriture de l'objet
  79. WRITE(IOPER,1201) CHNOM
  80.  
  81. NBNN=MELEME.NUM(/1)
  82. C Boucle sur les triangles
  83. DO IT3=1,NBELEM
  84. C Recuperation des COORDONNEES
  85. INO =1
  86. IPT =(NUM(INO,IT3)-1)*(IDIM+1) + 1
  87. X1 = XCOOR(IPT )
  88. X2 = XCOOR(IPT + 1)
  89. X3 = XCOOR(IPT + 2)
  90. INO =2
  91. IPT =(NUM(INO,IT3)-1)*(IDIM+1) + 1
  92. Y1 = XCOOR(IPT )
  93. Y2 = XCOOR(IPT + 1)
  94. Y3 = XCOOR(IPT + 2)
  95. INO =3
  96. IPT =(NUM(INO,IT3)-1)*(IDIM+1) + 1
  97. Z1 = XCOOR(IPT )
  98. Z2 = XCOOR(IPT + 1)
  99. Z3 = XCOOR(IPT + 2)
  100.  
  101. C Calcul du produit vectoriel
  102. U1= Y1 - X1
  103. U2= Y2 - X2
  104. U3= Y3 - X3
  105.  
  106. V1= Z1 - X1
  107. V2= Z2 - X2
  108. V3= Z3 - X3
  109.  
  110. W1= (U2*V3) - (U3*V2)
  111. W2= (U3*V1) - (U1*V3)
  112. W3= (U1*V2) - (U2*V1)
  113.  
  114. XNORM = SQRT((W1**2) + (W2**2) + (W3**2))
  115.  
  116. IF (XNORM .GT. REAL(0.D0)) THEN
  117. W1= W1 / XNORM
  118. W2= W2 / XNORM
  119. W3= W3 / XNORM
  120. ELSE
  121. SEGDES,MELEME
  122. CALL ERREUR(808)
  123. RETURN
  124. ENDIF
  125.  
  126. C Ecriture de la Normale
  127. WRITE(IOPER,1202) W1,W2,W3
  128. WRITE(IOPER,1203)
  129.  
  130. C Ecriture des coordonnees des noeuds
  131. WRITE(IOPER,1204) X1,X2,X3
  132. WRITE(IOPER,1204) Y1,Y2,Y3
  133. WRITE(IOPER,1204) Z1,Z2,Z3
  134.  
  135. WRITE(IOPER,1205)
  136. WRITE(IOPER,1206)
  137. ENDDO
  138. WRITE(IOPER,1207) CHNOM
  139.  
  140. SEGDES,MELEME
  141.  
  142. RETURN
  143. END
  144.  
  145.  
  146.  
  147.  

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