Télécharger lirstl.eso

Retour à la liste

Numérotation des lignes :

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

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