Télécharger la plaquette Cast3M


fr en

Télécharger sorstl.eso

Retour à la liste

Numérotation des lignes : 

sorstl

  1. C SORSTL    SOURCE    CB215821  23/01/25    21:15:36     11573          
  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.       CALL ACTOBJ('MAILLAGE',MELEME,1)
  37.       IF(IERR .NE. 0) RETURN
  38.  
  39. C     Lecture du nom du dernier objet lu
  40.       CALL QUENOM(CHNOM)
  41.  
  42.       NBSOUS=MELEME.LISOUS(/1)
  43.  
  44.       IF(NBSOUS .NE. 0)THEN
  45.         CALL ERREUR(21)
  46.         RETURN
  47.       ELSE
  48.         IF(ITYPEL .NE. ITRI3)THEN
  49.           CALL ERREUR(16)
  50.           RETURN
  51.         ENDIF
  52.       ENDIF
  53.  
  54.       NBELEM=MELEME.NUM(/2)
  55.       IF (NBELEM .EQ. 0) THEN
  56.         CALL ERREUR(21)
  57.         RETURN
  58.       ENDIF
  59.  
  60.       IF (IDIM .NE. 3) THEN
  61.         INTERR(1)=IDIM
  62.         CALL ERREUR(709)
  63.         RETURN
  64.       ENDIF
  65.  
  66. C     Specification des differents FORMATS ASCII a sortir
  67.  1201 FORMAT('solid ',A)
  68.  1202 FORMAT('facet normal ',ES13.5,1X,ES13.5,1X,ES13.5)
  69.  1203 FORMAT('outer loop')
  70.  1204 FORMAT('vertex ',ES13.5,1X,ES13.5,1X,ES13.5)
  71.  1205 FORMAT('endloop')
  72.  1206 FORMAT('endfacet')
  73.  1207 FORMAT('endsolid ', A)
  74.  
  75.  
  76. C     Debut de l'ecriture de l'objet
  77.       WRITE(IOPER,1201) CHNOM
  78.  
  79.       NBNN=MELEME.NUM(/1)
  80. C     Boucle sur les triangles
  81.       SEGACT,MCOORD
  82.       DO IT3=1,NBELEM
  83. C       Recuperation des COORDONNEES
  84.         INO =1
  85.         IPT =(NUM(INO,IT3)-1)*(IDIM+1) + 1
  86.         X1  = XCOOR(IPT    )
  87.         X2  = XCOOR(IPT + 1)
  88.         X3  = XCOOR(IPT + 2)
  89.         INO =2
  90.         IPT =(NUM(INO,IT3)-1)*(IDIM+1) + 1
  91.         Y1  = XCOOR(IPT    )
  92.         Y2  = XCOOR(IPT + 1)
  93.         Y3  = XCOOR(IPT + 2)
  94.         INO =3
  95.         IPT =(NUM(INO,IT3)-1)*(IDIM+1) + 1
  96.         Z1  = XCOOR(IPT    )
  97.         Z2  = XCOOR(IPT + 1)
  98.         Z3  = XCOOR(IPT + 2)
  99.  
  100. C       Calcul du produit vectoriel
  101.         U1= Y1 - X1
  102.         U2= Y2 - X2
  103.         U3= Y3 - X3
  104.  
  105.         V1= Z1 - X1
  106.         V2= Z2 - X2
  107.         V3= Z3 - X3
  108.  
  109.         W1= (U2*V3) - (U3*V2)
  110.         W2= (U3*V1) - (U1*V3)
  111.         W3= (U1*V2) - (U2*V1)
  112.  
  113.         XNORM = SQRT((W1**2) + (W2**2) + (W3**2))
  114.  
  115.         IF (XNORM .GT. REAL(0.D0)) THEN        
  116.           W1= W1 / XNORM
  117.           W2= W2 / XNORM
  118.           W3= W3 / XNORM
  119.         ELSE
  120.           CALL ERREUR(808)
  121.           RETURN
  122.         ENDIF        
  123.  
  124. C       Ecriture de la Normale
  125.         WRITE(IOPER,1202) W1,W2,W3
  126.         WRITE(IOPER,1203)
  127.  
  128. C       Ecriture des coordonnees des noeuds
  129.         WRITE(IOPER,1204) X1,X2,X3
  130.         WRITE(IOPER,1204) Y1,Y2,Y3
  131.         WRITE(IOPER,1204) Z1,Z2,Z3
  132.  
  133.         WRITE(IOPER,1205)
  134.         WRITE(IOPER,1206)
  135.       ENDDO
  136.       SEGDES,MCOORD
  137.       WRITE(IOPER,1207) CHNOM
  138.  
  139.       RETURN
  140.       END
  141.  
  142.  

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