Télécharger lirstl.eso

Retour à la liste

Numérotation des lignes :

  1. C LIRSTL SOURCE CB215821 16/12/13 21:15:09 9251
  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.  
  29. SEGMENT ISOLID(NBSOLI)
  30.  
  31. C Déclarations
  32. CHARACTER*256 FicSTL
  33. CHARACTER*80 LIGNE
  34. CHARACTER*4 COLO4
  35. CHARACTER*6 COLO6,COLO6b
  36. CHARACTER*7 COLO7
  37. CHARACTER*8 COLO8
  38. CHARACTER*9 COLO9,MOT1,MOT2
  39.  
  40. INTEGER*4 NTRI
  41. C INTEGER*2 IATTRI
  42.  
  43. REAL*4 TOTO
  44.  
  45. C*****************************************************************
  46. C Début des instructions
  47. C*****************************************************************
  48. C Initialisations
  49. I1 = 0
  50. NTRI = 0
  51. C IATTRI = 0
  52. L = 0
  53. IPT1 = 0
  54. ISOLID = 0
  55. NBTOTA = 0
  56. NBSOLI = 0
  57.  
  58. C Unite logique du fichier d'impression au format .stl et nom du fichier
  59. IUSTL = IOPER
  60.  
  61. NBNN = 3
  62. NBSOUS = 0
  63. NBREF = 0
  64. ITRI3 = 0
  65. COLO4 ='TRI3'
  66. COLO9 =' '
  67. CALL PLACE(NOMS,NOMBR,ITRI3,COLO4)
  68.  
  69. C Changement de dimension (si necessaire)
  70. IDIMI=IDIM
  71. IDIMF=3
  72. IF (IDIMF .NE. IDIMI) THEN
  73. CALL ECRENT(IDIMF)
  74. CALL ECRCHA('DIME')
  75. CALL OPTION(1)
  76. IF (IERR.NE.0) THEN
  77. CALL ERREUR(IERR)
  78. RETURN
  79. ENDIF
  80. WRITE(IOIMP,*) ' '
  81. WRITE(IOIMP,*) ' Passage en DIMEnsion 3'
  82. WRITE(IOIMP,*) ' '
  83. ENDIF
  84. idimp1=IDIM+1
  85.  
  86. NBANC=XCOOR(/1)/idimp1
  87.  
  88. C Lecture des arguments : Nom du fichier à lire (toto.stl)
  89. CALL LIRCHA(FicSTL,1,IRETO1)
  90. IF (IERR.NE.0) RETURN
  91.  
  92. C Par defaut, Erreur Cast3M numero 424
  93. C Erreur 424 : Problème %i1 en ouvrant le fichier : %m1:40
  94. L=LEN(FicSTL)
  95. MOTERR(1:L)=FicSTL(1:L)
  96. INTERR(1)=0
  97.  
  98. C Fermeture de l'unite logique au cas ou .stl
  99. CLOSE(UNIT=IUSTL,ERR=991)
  100.  
  101. C*****************************************************************
  102. C Tentative de lecture du STL ASCII
  103. C*****************************************************************
  104. C Acquisition de la premiere ligne en FORMATTED
  105. OPEN (UNIT=IUSTL,STATUS='OLD',FILE=FicSTL(1:L),
  106. & IOSTAT=IOS,ERR=990,FORM='FORMATTED',ACCESS='SEQUENTIAL')
  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. 1001 FORMAT(A9)
  130.  
  131. 100 CONTINUE
  132. C Lecture en boucle pour compter le nombre d'entite
  133. READ(IUSTL,1001,ERR=992,END=992) COLO9
  134.  
  135. IF (COLO9(1:6) .EQ. 'facet ') THEN
  136. NBENTI = NBENTI + 1
  137. NBTOTA = NBTOTA + 1
  138.  
  139. ELSEIF(COLO9 .EQ. 'endsolid ') THEN
  140. ISOLID(NBSOLI)=NBENTI
  141. C PRINT *,'NBSOLID',NBSOLI,ISOLID(NBSOLI)
  142. GOTO 99
  143. ENDIF
  144. GOTO 100
  145.  
  146. 200 CONTINUE
  147. C On est arrive a la fin des Solid
  148. IF (NBSOLI .EQ. 0) GOTO 993
  149.  
  150. REWIND IUSTL
  151.  
  152. C Ajustement du segment MCOORD
  153. NBPTS=NBANC + (NBTOTA * 3)
  154. SEGADJ,MCOORD
  155.  
  156. NBELEM=NBTOTA
  157. SEGINI,IPT1
  158. IPT1.ITYPEL=ITRI3
  159.  
  160.  
  161. 1002 FORMAT(A6,A6,1X,E13.5,1X,E13.5,1X,E13.5)
  162. 1003 FORMAT(A6,A4)
  163. 1004 FORMAT(A6,1X,E13.5,1X,E13.5,1X,E13.5)
  164.  
  165. K=0
  166. IDEB=0
  167. DO ISOLI=1,NBSOLI
  168. C Lecture d'un Solid
  169. READ(IUSTL,1000,ERR=992,END=993) LIGNE
  170. DO ITR=1,ISOLID(NBSOLI)
  171. ITRI = ITR + IDEB
  172. C Lecture des Normales et 'outer loop'
  173. READ(IUSTL,1002,ERR=992,END=993) COLO6,COLO6b,X1,X2,X3
  174. READ(IUSTL,1003,ERR=992,END=993) COLO6,COLO4
  175.  
  176. C Lecture des 3 coordonnées des 3 sommets REAL32
  177. READ(IUSTL,1004,ERR=992,END=993) COLO6,X1,X2,X3
  178. K=K+1
  179. MCOORD.XCOOR((NBANC+K-1)*idimp1 + 1)=X1
  180. MCOORD.XCOOR((NBANC+K-1)*idimp1 + 2)=X2
  181. MCOORD.XCOOR((NBANC+K-1)*idimp1 + 3)=X3
  182. MCOORD.XCOOR((NBANC+K-1)*idimp1 + 4)=REAL(0.D0)
  183. IPT1.NUM(1,ITRI)=NBANC + K
  184.  
  185.  
  186. READ(IUSTL,1004,ERR=992,END=993) COLO6,X1,X2,X3
  187. K=K+1
  188. MCOORD.XCOOR((NBANC+K-1)*idimp1 + 1)=X1
  189. MCOORD.XCOOR((NBANC+K-1)*idimp1 + 2)=X2
  190. MCOORD.XCOOR((NBANC+K-1)*idimp1 + 3)=X3
  191. MCOORD.XCOOR((NBANC+K-1)*idimp1 + 4)=REAL(0.D0)
  192. IPT1.NUM(2,ITRI)=NBANC + K
  193.  
  194. READ(IUSTL,1004,ERR=992,END=993) COLO6,X1,X2,X3
  195. K=K+1
  196. MCOORD.XCOOR((NBANC+K-1)*idimp1 + 1)=X1
  197. MCOORD.XCOOR((NBANC+K-1)*idimp1 + 2)=X2
  198. MCOORD.XCOOR((NBANC+K-1)*idimp1 + 3)=X3
  199. MCOORD.XCOOR((NBANC+K-1)*idimp1 + 4)=REAL(0.D0)
  200. IPT1.NUM(3,ITRI)=NBANC + K
  201.  
  202. C Lecture de 'endloop' et 'endfacet'
  203. READ(IUSTL,1001,ERR=992,END=993) COLO7
  204. READ(IUSTL,1001,ERR=992,END=993) COLO8
  205. ENDDO
  206. C Lecture de EndSolid
  207. READ(IUSTL,1001,ERR=992,END=992) COLO9
  208. IDEB = ITRI
  209. ENDDO
  210.  
  211.  
  212. 993 CONTINUE
  213. C Sortie normale ASCII
  214. CALL ECROBJ('MAILLAGE',IPT1)
  215. SEGDES,IPT1
  216. IF (ISOLID .GT. 0) SEGSUP,ISOLID
  217.  
  218. CLOSE(UNIT=IUSTL,ERR=991)
  219. RETURN
  220.  
  221. 8000 CONTINUE
  222. C*****************************************************************
  223. C Lecture du STL binaire
  224. C*****************************************************************
  225. C Acquisition de la premiere ligne UINT8[80] en UNFORMATTED
  226. C Inutile dans Cast3M...
  227. C OPEN (UNIT=IUSTL,STATUS='OLD',FILE=FicSTL(1:L),
  228. C & IOSTAT=IOS,ERR=990,FORM='UNFORMATTED',ACCESS='DIRECT',
  229. C & RECL=80)
  230. C IF (IOS .NE. 0) GOTO 990
  231.  
  232. C READ(IUSTL,REC=1,ERR=992) LIGNE
  233. C CLOSE(IUSTL,STATUS='KEEP',ERR=991)
  234.  
  235. C Acquisition du nombre de TRIANGLES a lire UINT32
  236. OPEN (UNIT=IUSTL,STATUS='OLD',FILE=FicSTL(1:L),
  237. & IOSTAT=IOS,ERR=990,FORM='UNFORMATTED',ACCESS='DIRECT',
  238. & RECL=4)
  239. IF (IOS .NE. 0) GOTO 990
  240.  
  241. READ(IUSTL,REC=21,ERR=992) ntri
  242. CLOSE(IUSTL,STATUS='KEEP',ERR=991)
  243. NBENTI = INT(ntri)
  244. C PRINT *,'Binaire avec ',NBENTI,'Triangles'
  245.  
  246. C Ajustement du segment MCOORD
  247. NBPTS=NBANC + (NBENTI * 3)
  248. SEGADJ,MCOORD
  249.  
  250. NBELEM=NBENTI
  251. SEGINI,IPT1
  252. IPT1.ITYPEL=ITRI3
  253.  
  254. OPEN (UNIT=IUSTL,STATUS='OLD',FILE=FicSTL(1:L),
  255. & IOSTAT=IOS,ERR=990,FORM='UNFORMATTED',ACCESS='DIRECT',RECL=2)
  256. IF (IOS .NE. 0) GOTO 990
  257.  
  258. IRC=(80+4)/2+1
  259.  
  260. K=0
  261. DO I1=1,NBENTI
  262. C Les normales ne nous interessent pas dans Cast3M, on les saute
  263. C CALL BINSTL(IUSTL,W1,IRCIRET)
  264. C IF (IRET .NE. 1) GOTO 992)
  265. C CALL BINSTL(IUSTL,W2,IRCIRET)
  266. C IF (IRET .NE. 1) GOTO 992)
  267. C CALL BINSTL(IUSTL,W3,IRCIRET)
  268. C IF (IRET .NE. 1) GOTO 992)
  269. C normals(1,I1)=n(1)
  270. C normals(2,I1)=n(2)
  271. C normals(3,I1)=n(3)
  272. IRC=IRC + 6
  273.  
  274. C Lecture des 3 coordonnées des 3 sommets REAL32
  275. K=K+1
  276. CALL BINSTL(IUSTL,TOTO,IRC,IRET)
  277. IF (IRET .NE. 1) GOTO 992
  278. MCOORD.XCOOR((NBANC+K-1)*idimp1 + 1)=REAL(TOTO)
  279. CALL BINSTL(IUSTL,TOTO,IRC,IRET)
  280. IF (IRET .NE. 1) GOTO 992
  281. MCOORD.XCOOR((NBANC+K-1)*idimp1 + 2)=REAL(TOTO)
  282. CALL BINSTL(IUSTL,TOTO,IRC,IRET)
  283. IF (IRET .NE. 1) GOTO 992
  284. MCOORD.XCOOR((NBANC+K-1)*idimp1 + 3)=REAL(TOTO)
  285. MCOORD.XCOOR((NBANC+K-1)*idimp1 + 4)=REAL(0.D0)
  286. IPT1.NUM(1,I1)=NBANC + K
  287.  
  288. K=K+1
  289. CALL BINSTL(IUSTL,TOTO,IRC,IRET)
  290. IF (IRET .NE. 1) GOTO 992
  291. MCOORD.XCOOR((NBANC+K-1)*idimp1 + 1)=REAL(TOTO)
  292. CALL BINSTL(IUSTL,TOTO,IRC,IRET)
  293. IF (IRET .NE. 1) GOTO 992
  294. MCOORD.XCOOR((NBANC+K-1)*idimp1 + 2)=REAL(TOTO)
  295. CALL BINSTL(IUSTL,TOTO,IRC,IRET)
  296. IF (IRET .NE. 1) GOTO 992
  297. MCOORD.XCOOR((NBANC+K-1)*idimp1 + 3)=REAL(TOTO)
  298. MCOORD.XCOOR((NBANC+K-1)*idimp1 + 4)=REAL(0.D0)
  299. IPT1.NUM(2,I1)=NBANC + K
  300.  
  301. K=K+1
  302. CALL BINSTL(IUSTL,TOTO,IRC,IRET)
  303. IF (IRET .NE. 1) GOTO 992
  304. MCOORD.XCOOR((NBANC+K-1)*idimp1 + 1)=REAL(TOTO)
  305. CALL BINSTL(IUSTL,TOTO,IRC,IRET)
  306. IF (IRET .NE. 1) GOTO 992
  307. MCOORD.XCOOR((NBANC+K-1)*idimp1 + 2)=REAL(TOTO)
  308. CALL BINSTL(IUSTL,TOTO,IRC,IRET)
  309. IF (IRET .NE. 1) GOTO 992
  310. MCOORD.XCOOR((NBANC+K-1)*idimp1 + 3)=REAL(TOTO)
  311. MCOORD.XCOOR((NBANC+K-1)*idimp1 + 4)=REAL(0.D0)
  312. IPT1.NUM(3,I1)=NBANC + K
  313.  
  314.  
  315. C Acquisition de l'attribut UINT16
  316. C Inutile dans Cast3M
  317. C READ(IUSTL,REC=IRC,ERR=992) IATTRI
  318. IRC=IRC+1
  319. ENDDO
  320.  
  321. C Sortie normale
  322. CALL ECROBJ('MAILLAGE',IPT1)
  323. SEGDES,IPT1
  324.  
  325. CLOSE(UNIT=IUSTL,ERR=991)
  326. RETURN
  327.  
  328.  
  329. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  330. C GESTION DES ERREURS
  331. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  332. 990 CONTINUE
  333. C ERREUR en ouvrant le fichier
  334. IF (IPT1 .GT. 0) SEGDES,IPT1
  335. IF (ISOLID .GT. 0) SEGSUP,ISOLID
  336. C PRINT *,'ERREUR en ouvrant le fichier :',FicSTL(1:L)
  337. CALL ERREUR(21)
  338. RETURN
  339.  
  340. 991 CONTINUE
  341. C ERREUR en fermant le fichier
  342. IF (IPT1 .GT. 0) SEGDES,IPT1
  343. IF (ISOLID .GT. 0) SEGSUP,ISOLID
  344. C PRINT *,'ERREUR en fermant le fichier :',FicSTL(1:L)
  345. CALL ERREUR(21)
  346. RETURN
  347.  
  348. 992 CONTINUE
  349. C ERREUR en lisant le fichier
  350. IF (IPT1 .GT. 0) SEGDES,IPT1
  351. IF (ISOLID .GT. 0) SEGSUP,ISOLID
  352. INTERR(1)=IUSTL
  353. CALL ERREUR(624)
  354. CLOSE(UNIT=IUSTL,ERR=991)
  355. RETURN
  356.  
  357. END
  358.  
  359.  
  360.  
  361.  

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