Télécharger la plaquette Cast3M


fr en

Télécharger lirstl.eso

Retour à la liste

Numérotation des lignes : 

lirstl

  1. C LIRSTL    SOURCE    CB215821  20/07/16    21:15:01     10654          
  2.       SUBROUTINE LIRSTL
  3.  
  4. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  5. C
  6. C BUT: Lecture des MAILLAGES de TRI3 au format STL ASCII et BINAIRE
  7. C      Les résultats sont ecrits en GIBIANE sous forme d'un MAILLAGE.
  8. C
  9. C Auteur : Clément BERTHINIER
  10. C          Décembre 2016
  11. C
  12. C Liste des Corrections :
  13. C  -
  14. C  -
  15. C  -
  16. C
  17. C Appelé par : LIREFI
  18. C
  19. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  20.  
  21.       IMPLICIT INTEGER(I-N)
  22.       IMPLICIT REAL*8(A-H,O-Z)
  23.  
  24. -INC PPARAM
  25. -INC CCOPTIO
  26. -INC CCGEOME
  27. -INC SMELEME
  28. -INC SMCOORD
  29. -INC CCREDLE
  30.  
  31.       SEGMENT ISOLID(NBSOLI)
  32.  
  33. C Déclarations
  34.       EXTERNAL      LONG
  35. C     LOCHAI dans CCNOYAU.INC
  36.       CHARACTER*(LOCHAI) FicSTL
  37.       CHARACTER*80  LIGNE
  38.       CHARACTER*4   COLO4
  39.  
  40.       INTEGER*4     NTRI
  41. C      INTEGER*2     IATTRI
  42.  
  43.       REAL*4        FLO4
  44.       LOGICAL       EX
  45.  
  46. C*****************************************************************
  47. C     Début des instructions
  48. C*****************************************************************
  49. C     Initialisations
  50.       I1     = 0
  51.       NTRI   = 0
  52. C     IATTRI = 0
  53.       L      = 0
  54.       IPT1   = 0
  55.       ISOLID = 0
  56.       NBTOTA = 0
  57.       NBSOLI = 0
  58.       ISOLI  = 0
  59.  
  60. C     Unite logique du fichier d'impression au format .stl et nom du fichier
  61.       IUSTL  = IOPER
  62.  
  63.       NBNN   = 3
  64.       NBSOUS = 0
  65.       NBREF  = 0
  66.       ITRI3  = 0
  67.       COLO4  ='TRI3'
  68.       CALL PLACE(NOMS,NOMBR,ITRI3,COLO4)
  69.  
  70. C     Lecture du nom du fichier à lire
  71.       CALL LIRCHA(FicSTL,1,IRETO1)
  72.       IF (IERR.NE.0) RETURN
  73.       L=LONG(FicSTL)
  74.  
  75. C     Teste l'existence du fichier
  76.       INQUIRE(FILE=FicSTL,EXIST=EX)
  77.       IOS=0
  78.       IF (.NOT. EX) GOTO 990
  79.  
  80. C Ouverture du fichier
  81. C     Fermeture de l'unite logique au cas ou .stl
  82.       CLOSE(UNIT=IUSTL,ERR=991)
  83.  
  84. C     Changement de dimension (si necessaire)
  85.       IDIMI=IDIM
  86.       IDIMF=3
  87.       IF (IDIMF .NE. IDIMI) THEN
  88.         CALL ECRENT(IDIMF)
  89.         CALL ECRCHA('DIME')
  90.         CALL OPTION(1)
  91.         IF (IERR.NE.0) THEN
  92.           CALL ERREUR(21)
  93.           RETURN
  94.         ENDIF
  95.         WRITE(IOIMP,*) '     Passage en DIMEnsion 3'
  96.       ENDIF
  97.       idimp1=IDIM+1
  98.  
  99.       SEGACT,MCOORD*MOD
  100.       NBANC=nbpts
  101.  
  102. C*****************************************************************
  103. C     Tentative de lecture du STL ASCII
  104. C*****************************************************************
  105. C     Acquisition de la premiere ligne en FORMATTED
  106.       OPEN (UNIT=IUSTL,STATUS='OLD',FILE=FicSTL,
  107.      &     IOSTAT=IOS,ERR=990,FORM='FORMATTED',ACCESS='SEQUENTIAL')
  108.  
  109. C     Traitement des erreurs d'ouverture des fichiers
  110.       IF (IOS .NE. 0) GOTO 990
  111.  
  112.  1000 FORMAT(A80)
  113.  
  114. C     Lecture de tout le fichier pour trouver des endsolid (Puisqu'apparemment le 'solid ' n'est pas determinant...)
  115.  10   CONTINUE
  116.       READ(IUSTL,1000,ERR=992,END=11) LIGNE
  117.  
  118.       IPOS1=INDEX(LIGNE,'endsolid')
  119.       IF (IPOS1 .NE. 0) THEN
  120.         NBSOLI=NBSOLI+1
  121. C       PRINT *,'NBSOLID',NBSOLI,ISOLID(NBSOLI)
  122.       ENDIF
  123.       GOTO 10
  124. C     Fin du fichier
  125.  11   CONTINUE
  126.  
  127.       IF(NBSOLI .EQ. 0)THEN
  128. C       PRINT *,'     FORMAT ASCII non detecte, lecture binaire'
  129.         CLOSE(UNIT=IUSTL,ERR=991)
  130.         GOTO 8000
  131.       ELSE
  132. C       PRINT *,'     FORMAT ASCII detecte'
  133.         REWIND IUSTL
  134.         ISOLI = 0
  135.       ENDIF
  136.  
  137.       SEGINI,ISOLID
  138.  99   CONTINUE
  139.       NBENTI = 0
  140. C     Lecture d'un Nouveau Solid
  141.       READ(IUSTL,1000,ERR=992,END=200) LIGNE
  142.  
  143.       IF (LIGNE(1:6) .NE. 'solid ') THEN
  144.         GOTO 99
  145.       ELSE
  146.         ISOLI=ISOLI+1
  147.       ENDIF
  148.  
  149.  100  CONTINUE
  150. C     Lecture en boucle pour compter le nombre d'entite
  151.       READ(IUSTL,1000,ERR=992,END=992) LIGNE
  152.  
  153.       IPOS1=INDEX(LIGNE,'endsolid')
  154.       IF (IPOS1 .NE. 0) THEN
  155.         ISOLID(ISOLI)=NBENTI
  156. C       PRINT *,'NBSOLID',ISOLI,ISOLID(ISOLI)
  157.         GOTO 99
  158.       ENDIF
  159.  
  160.       IPOS2=INDEX(LIGNE,'facet normal')
  161.       IF (IPOS2 .NE. 0) THEN
  162.         NBENTI = NBENTI + 1
  163.         NBTOTA = NBTOTA + 1
  164.       ENDIF
  165.       GOTO 100
  166.  
  167.  200  CONTINUE
  168. C     On est arrive a la fin des Solid
  169. C     PRINT *,'On a lu ',ISOLI,' Solid'
  170.       IF (ISOLI .EQ. 0) GOTO 993
  171.  
  172.       REWIND IUSTL
  173.  
  174. C     Ajustement du segment MCOORD
  175.       NBPTS=NBANC + (NBTOTA * 3)
  176.       SEGADJ,MCOORD
  177.  
  178.       NBELEM=NBTOTA
  179.       SEGINI,IPT1
  180.       IPT1.ITYPEL=ITRI3
  181. C     PRINT *,''
  182.  
  183.       K=0
  184.       IDEB=0
  185.       NUMLIG=0
  186.       SEGINI,SREDLE
  187.       DO ISOLI=1,NBSOLI
  188. C       Lecture d'un Solid
  189.         READ(IUSTL,1000,ERR=992,END=993) LIGNE
  190.         NUMLIG=NUMLIG+1
  191.         DO ITR=1,ISOLID(ISOLI)
  192. C         Lecture de 'facet normal' et 'outer loop'
  193.           READ(IUSTL,1000,ERR=992,END=993) LIGNE
  194.           NUMLIG=NUMLIG+1
  195.           IPOS=INDEX(LIGNE,'facet normal')
  196.           IF (IPOS .EQ. 0) THEN
  197.             PRINT *,'Ligne ',NUMLIG,'On attendais : facet normal'
  198.             GOTO 992
  199. C         ELSE
  200. C           PRINT *,'On a lu facet normal'
  201.           ENDIF
  202.           READ(IUSTL,1000,ERR=992,END=993) LIGNE
  203.           NUMLIG=NUMLIG+1
  204.           IPOS=INDEX(LIGNE,'outer loop')
  205.           IF (IPOS .EQ. 0) THEN
  206.             PRINT *,'Ligne ',NUMLIG,'On attendais : outer loop'
  207.             GOTO 992
  208. C         ELSE
  209. C           PRINT *,'On a lu outer loop'
  210.           ENDIF
  211.  
  212. C         Lecture des 3 coordonnées des 3 noeuds REAL32
  213.           DO INOEU=1,3
  214.             READ(IUSTL,1000,ERR=992,END=993) LIGNE
  215.             NUMLIG=NUMLIG+1
  216.             IPOS=INDEX(LIGNE,'vertex')
  217.             IF (IPOS .EQ. 0) THEN
  218.               PRINT *,'Ligne ',NUMLIG,'On attendais : vertex'
  219.               GOTO 992
  220. C            ELSE
  221. C              PRINT *,'On a lu vertex'
  222.             ENDIF
  223.  
  224.             ITRI = IDEB + ITR
  225.             K=K+1
  226.             IPT1.NUM(INOEU,ITRI)=NBANC + K
  227.  
  228.             IPOS2 = IPOS+6
  229.  
  230. C           On va lire 3 coordonnees
  231.             DO IVAL=1,3
  232.               IPOS1=IPOS2
  233.  101          CONTINUE
  234.               IF(LIGNE(IPOS1+1:IPOS1+1) .EQ. ' ')THEN
  235.                 IPOS1 = IPOS1+1
  236.                 GOTO 101
  237.               ENDIF
  238.               IPOS2=IPOS1+INDEX(LIGNE(IPOS1+1:80),' ')
  239.               TEXT=LIGNE(IPOS1+1:IPOS2-1)
  240.               NRAN =0
  241.               ICOUR=IPOS2-IPOS1-1
  242.               CALL redlec(SREDLE)
  243.               MCOORD.XCOOR((NBANC+K-1)*idimp1 + IVAL)=FLOT
  244. C            PRINT *,'FLOT:',IRE,':',TEXT(1:ICOUR),':',FLOT
  245.             ENDDO
  246.             MCOORD.XCOOR((NBANC+K-1)*idimp1 + 4)=REAL(0.D0)
  247.           ENDDO
  248.  
  249. C         Lecture de 'endloop' et 'endfacet'
  250.           READ(IUSTL,1000,ERR=992,END=993) LIGNE
  251.           NUMLIG=NUMLIG+1
  252.           IPOS=INDEX(LIGNE,'endloop')
  253.           IF (IPOS .EQ. 0) THEN
  254.             PRINT *,'Ligne ',NUMLIG,'On attendais : endloop'
  255.             GOTO 992
  256. C         ELSE
  257. C           PRINT *,'On a lu endloop'
  258.           ENDIF
  259.           READ(IUSTL,1000,ERR=992,END=993) LIGNE
  260.           NUMLIG=NUMLIG+1
  261.           IPOS=INDEX(LIGNE,'endfacet')
  262.           IF (IPOS .EQ. 0) THEN
  263.             PRINT *,'Ligne ',NUMLIG,'On attendais : endfacet'
  264.             GOTO 992
  265. C         ELSE
  266. C           PRINT *,'On a lu endfacet'
  267.           ENDIF
  268.         ENDDO
  269. C       Lecture de 'endsolid'
  270.         READ(IUSTL,1000,ERR=992,END=993) LIGNE
  271.         NUMLIG=NUMLIG+1
  272.         IPOS=INDEX(LIGNE,'endsolid')
  273.         IF (IPOS .EQ. 0) THEN
  274.           PRINT *,'Ligne ',NUMLIG,'On attendais : endsolid'
  275.           GOTO 992
  276. C       ELSE
  277. C         PRINT *,'On a lu endsolid'
  278.         ENDIF
  279.         IDEB = ITRI
  280.       ENDDO
  281.       SEGSUP,SREDLE
  282.  
  283.  
  284.  993  CONTINUE
  285. C     Sortie normale ASCII
  286.       CALL ECROBJ('MAILLAGE',IPT1)
  287.       SEGDES,IPT1,MCOORD
  288.       IF (ISOLID .GT. 0) SEGSUP,ISOLID
  289.  
  290.       CLOSE(UNIT=IUSTL,ERR=991)
  291.       RETURN
  292.  
  293.  8000 CONTINUE
  294. C*****************************************************************
  295. C     Lecture du STL binaire
  296. C*****************************************************************
  297. C     Acquisition du nombre de TRIANGLES a lire UINT32
  298.       OPEN (UNIT=IUSTL,STATUS='OLD',FILE=FicSTL,
  299.      &     IOSTAT=IOS,ERR=990,FORM='UNFORMATTED',ACCESS='DIRECT',
  300.      &     RECL=4)
  301.       IF (IOS .NE. 0) GOTO 990
  302.  
  303.       READ(IUSTL,REC=21,ERR=992) ntri
  304.       CLOSE(IUSTL,STATUS='KEEP',ERR=991)
  305.       NBENTI = INT(ntri)
  306. C     PRINT *,'Binaire avec ',NBENTI,'Triangles'
  307.  
  308. C     Ajustement du segment MCOORD
  309.       NBPTS=NBANC + (NBENTI * 3)
  310.       SEGADJ,MCOORD
  311.  
  312.       NBELEM=NBENTI
  313.       SEGINI,IPT1
  314.       IPT1.ITYPEL=ITRI3
  315.  
  316.       OPEN (UNIT=IUSTL,STATUS='OLD',FILE=FicSTL,
  317.      &     IOSTAT=IOS,ERR=990,FORM='UNFORMATTED',ACCESS='DIRECT',RECL=2)
  318.       IF (IOS .NE. 0) GOTO 990
  319.  
  320.       IRC=(80+4)/2+1
  321.  
  322.       K=0
  323.       DO I1=1,NBENTI
  324. C       Les normales ne nous interessent pas dans Cast3M, on les saute
  325.         IRC=IRC + 6
  326.  
  327. C       Lecture des 3 coordonnées des 3 sommets REAL32
  328.         DO INOEU=1,3
  329.           K=K+1
  330.           IPT1.NUM(INOEU,I1)=NBANC + K
  331.           DO IVAL=1,3
  332.             CALL BINSTL(IUSTL,FLO4,IRC,IRET)
  333.             IF (IRET .NE. 1) GOTO 992
  334.             MCOORD.XCOOR((NBANC+K-1)*idimp1 + IVAL)=REAL(FLO4)
  335.           ENDDO
  336.           MCOORD.XCOOR((NBANC+K-1)*idimp1 + 4)=REAL(0.D0)
  337.         ENDDO
  338.  
  339. C       Acquisition de l'attribut UINT16
  340. C       Inutile dans Cast3M
  341. C        READ(IUSTL,REC=IRC,ERR=992) IATTRI
  342.         IRC=IRC+1
  343.       ENDDO
  344.  
  345. C     Sortie normale
  346.       CALL ECROBJ('MAILLAGE',IPT1)
  347.       SEGDES,IPT1,MCOORD
  348.  
  349.       CLOSE(UNIT=IUSTL,ERR=991)
  350.       RETURN
  351.  
  352.  
  353. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  354. C      GESTION DES ERREURS
  355. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  356.  990  CONTINUE
  357. C     ERREUR en ouvrant le fichier
  358.       L1=MIN(L,40)
  359.       MOTERR   =FicSTL(1:L1)
  360.       INTERR(1)=IOS
  361.       CALL ERREUR(424)
  362.       RETURN
  363.  
  364.  991  CONTINUE
  365. C     ERREUR en fermant le fichier
  366.       CALL ERREUR(21)
  367.       RETURN
  368.  
  369.  992  CONTINUE
  370. C     ERREUR en lisant le fichier
  371.       INTERR(1)=IUSTL
  372.       CALL ERREUR(624)
  373.       RETURN
  374.  
  375.       END
  376.  
  377.  
  378.  
  379.  

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