Télécharger sornas.eso

Retour à la liste

Numérotation des lignes :

  1. C SORNAS SOURCE PV 20/03/24 21:22:15 10554
  2. SUBROUTINE SORNAS
  3.  
  4. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  5. C
  6. C But : Ecrire un maillage sous forme d'un
  7. C BULK DATA de NASTRAN
  8. C
  9. C Auteur : Michal Bulik
  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 CCGEOME
  19. -INC SMCOORD
  20. -INC SMELEME
  21.  
  22. INTEGER LISCOL(16),IEQCOL(16),NBCOL,NBPID,NBTEL
  23. INTEGER CU20(20),PR15(15),TE10(10),QUA8(8),TRI6(6)
  24. C INTEGER SEG3(3)
  25. REAL*8 YOUNG,NU,RHO,THICKN
  26. CHARACTER*8 CONTPL
  27. CHARACTER*8 CONTET
  28.  
  29. DATA IEQCOL /0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/
  30. DATA CU20 /1,3,5,7,13,15,17,19,2,4,6,8,9,10,11,12,14,16,18,20/
  31. DATA PR15 /1,3,5,10,12,14,2,4,6,7,8,9,11,13,15/
  32. DATA TE10 /1,3,5,10,2,4,6,7,8,9/
  33. DATA QUA8 /1,3,5,7,2,4,6,8/
  34. DATA TRI6 /1,3,5,2,4,6/
  35. C DATA SEG3 /1,3,2/
  36. DATA CONTPL /'+ '/
  37. DATA CONTET /'* '/
  38.  
  39. NBPID=0
  40. NBTEL=0
  41.  
  42. YOUNG = REAL(2.1D+11)
  43. RHO = REAL(7.85D+03)
  44. NU = REAL(0.3D+00)
  45.  
  46. CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU)
  47. IF(IRETOU.EQ.0) THEN
  48. WRITE(IOIMP,8001)
  49. 8001 FORMAT('ERREUR dans SORNAS : Pas de maillage trouve !')
  50. RETURN
  51. ENDIF
  52.  
  53. C ... Si le fichier existe deja, on va l'ecraser ...
  54.  
  55. REWIND IOPER
  56.  
  57. C ... Debut de BULK DATA ...
  58.  
  59. WRITE(IOPER,1000)
  60. 1000 FORMAT('BEGIN BULK')
  61.  
  62. C ... Le materiau commun ...
  63.  
  64. WRITE(IOPER,1100) 1,YOUNG,RHO,NU
  65. 1100 FORMAT('MAT1 ',I8,1PG8.2,G8.2,G8.2)
  66.  
  67. C ... Les noeuds ...
  68.  
  69. IF(IDIM.EQ.2) THEN
  70. DO 1200 I=1,NBPTS
  71. IPT=(I-1)*(IDIM+1) + 1
  72. WRITE(IOPER,1202) I,0,XCOOR(IPT),XCOOR(IPT+1),CONTET,CONTET,
  73. & 0.D0
  74. 1200 CONTINUE
  75. ELSE IF (IDIM.EQ.3) THEN
  76. DO 1210 I=1,NBPTS
  77. IPT=(I-1)*(IDIM+1) + 1
  78. WRITE(IOPER,1202) I,0,XCOOR(IPT),XCOOR(IPT+1),CONTET,CONTET,
  79. & XCOOR(IPT+2)
  80. 1210 CONTINUE
  81. ELSE
  82. WRITE(IOIMP,8002)
  83. 8002 FORMAT('ERREUR dans SORNAS : dimension incorrecte !')
  84. ENDIF
  85. C 1201 FORMAT('GRID ',I8,A8,3(F8.5))
  86. 1202 FORMAT('GRID* ',2I16,2E16.9,A8,/,A8,E16.9)
  87.  
  88. C ... Les connectivites ...
  89.  
  90. SEGACT MELEME
  91. NBSOUS=MAX(1,LISOUS(/1))
  92. IPT1=MELEME
  93. DO 1300 I=1,NBSOUS
  94. IF(LISOUS(/1).GT.0) IPT1=LISOUS(I)
  95. SEGACT IPT1
  96. LETYPE=IPT1.ITYPEL
  97. NBELTS=IPT1.NUM(/2)
  98.  
  99. C ... Boucle sur les couleurs pour connaitre le nb de nouveaux PID ...
  100. C ... Initialisation de IEQCOL (on y met l'equivalence entre les couleurs et les PID) ...
  101.  
  102. NBCOL=1
  103. LISCOL(NBCOL)=IPT1.ICOLOR(1)
  104. IEQCOL(IPT1.ICOLOR(1))=NBCOL
  105. DO 2000 IL=2,NBELTS
  106. DO 2001 IC=1,NBCOL
  107. IF(IPT1.ICOLOR(IL).EQ.LISCOL(IC)) GOTO 2000
  108. 2001 CONTINUE
  109. NBCOL=NBCOL+1
  110. LISCOL(NBCOL)=IPT1.ICOLOR(IL)
  111. IEQCOL(IPT1.ICOLOR(IL))=NBCOL
  112. 2000 CONTINUE
  113.  
  114. C ... On sort le nombre approprie des PID ...
  115. C ... Dans cet IF il faudra rajouter en alternative tous les ITYPEL
  116. C des elements SOLIDES, puis creer un autre ELSE IF pour des COQUES,
  117. C POUTRES, etc ...
  118.  
  119. IF(LETYPE.EQ.14) THEN
  120. DO 2002 IC=1,NBCOL
  121. NUMMAT=1
  122. WRITE(IOPER,5001) NBPID+IC,NUMMAT,NBPID+IC
  123. 5001 FORMAT('PSOLID ',2I8,48X,'SLD',I5.5)
  124. 2002 CONTINUE
  125. ELSE IF(LETYPE.EQ.15) THEN
  126. DO 2015 IC=1,NBCOL
  127. NUMMAT=1
  128. WRITE(IOPER,5004) NBPID+IC,NUMMAT,NBPID+IC
  129. 2015 CONTINUE
  130. ELSE IF(LETYPE.EQ.16) THEN
  131. DO 2005 IC=1,NBCOL
  132. NUMMAT=1
  133. WRITE(IOPER,5004) NBPID+IC,NUMMAT,NBPID+IC
  134. 5004 FORMAT('PSOLID ',2I8,48X,'SLD',I5.5)
  135. 2005 CONTINUE
  136. ELSE IF(LETYPE.EQ.17) THEN
  137. DO 2017 IC=1,NBCOL
  138. NUMMAT=1
  139. WRITE(IOPER,5004) NBPID+IC,NUMMAT,NBPID+IC
  140. 2017 CONTINUE
  141. ELSE IF(LETYPE.EQ.23) THEN
  142. DO 2023 IC=1,NBCOL
  143. NUMMAT=1
  144. WRITE(IOPER,5005) NBPID+IC,NUMMAT,NBPID+IC
  145. 5005 FORMAT('PSOLID ',2I8,48X,'SLD',I5.5)
  146. 2023 CONTINUE
  147. ELSE IF(LETYPE.EQ.24) THEN
  148. DO 2024 IC=1,NBCOL
  149. NUMMAT=1
  150. WRITE(IOPER,5005) NBPID+IC,NUMMAT,NBPID+IC
  151. 2024 CONTINUE
  152. ELSE IF(LETYPE.EQ.10) THEN
  153. DO 2010 IC=1,NBCOL
  154. NUMMAT=1
  155. THICKN=REAL(8.0D-2)
  156. WRITE(IOPER,5002) NBPID+IC,NUMMAT,THICKN,NBPID+IC
  157. 2010 CONTINUE
  158. ELSE IF(LETYPE.EQ.8) THEN
  159. DO 2003 IC=1,NBCOL
  160. NUMMAT=1
  161. THICKN=REAL(1.D0)
  162. WRITE(IOPER,5002) NBPID+IC,NUMMAT,THICKN,NBPID+IC
  163. 5002 FORMAT('PSHELL ',2I8,G8.2,40X,'SHL',I5.5)
  164. 2003 CONTINUE
  165. ELSE IF(LETYPE.EQ.6) THEN
  166. DO 2006 IC=1,NBCOL
  167. NUMMAT=1
  168. THICKN=REAL(6.0D-1)
  169. WRITE(IOPER,5003) NBPID+IC,NUMMAT,THICKN,NBPID+IC
  170. 2006 CONTINUE
  171. ELSE IF(LETYPE.EQ.4) THEN
  172. DO 2004 IC=1,NBCOL
  173. NUMMAT=1
  174. THICKN=REAL(1.D0)
  175. WRITE(IOPER,5003) NBPID+IC,NUMMAT,THICKN,NBPID+IC
  176. 5003 FORMAT('PSHELL ',2I8,G8.2,40X,'SHL',I5.5)
  177. 2004 CONTINUE
  178. ELSE IF(LETYPE.EQ.2) THEN
  179. DO 2007 IC=1,NBCOL
  180. NUMMAT=1
  181. THICKN=REAL(1.0D-2)
  182. WRITE(IOPER,5006) NBPID+IC,NUMMAT,THICKN,NBPID+IC
  183. 5006 FORMAT('PROD ',2I8,G8.2,40X,'ROD',I5.5)
  184. 2007 CONTINUE
  185. ENDIF
  186.  
  187. C ... Ecriture des conectivites ...
  188.  
  189. C ... Le TET4 ...
  190. IF(LETYPE.EQ.23) THEN
  191. DO 1323 IL=1,NBELTS
  192. WRITE(IOPER,1423) NBTEL+IL,NBPID+IEQCOL(IPT1.ICOLOR(IL)),
  193. & (IPT1.NUM(I1,IL),I1=1,4)
  194. 1423 FORMAT('CTETRA ',6I8)
  195. 1323 CONTINUE
  196. C ... Le TE10 ...
  197. ELSE IF(LETYPE.EQ.24) THEN
  198. DO 1324 IL=1,NBELTS
  199. WRITE(IOPER,1424) NBTEL+IL,NBPID+IEQCOL(IPT1.ICOLOR(IL)),
  200. & (IPT1.NUM(TE10(I1),IL),I1= 1, 6),CONTPL,CONTPL,
  201. & (IPT1.NUM(TE10(I1),IL),I1= 7,10)
  202. 1424 FORMAT('CTETRA ',8I8,A8,/,A8,4I8)
  203. 1324 CONTINUE
  204. C ... Le PR15 ...
  205. ELSE IF(LETYPE.EQ.17) THEN
  206. DO 1317 IL=1,NBELTS
  207. WRITE(IOPER,1417) NBTEL+IL,NBPID+IEQCOL(IPT1.ICOLOR(IL)),
  208. & (IPT1.NUM(PR15(I1),IL),I1= 1, 6),CONTPL,CONTPL,
  209. & (IPT1.NUM(PR15(I1),IL),I1= 7,14),CONTPL,CONTPL,
  210. & (IPT1.NUM(PR15(I1),IL),I1=15,15)
  211. 1417 FORMAT('CPENTA ',8I8,A8,/,A8,8I8,A8,/,A8,1I8)
  212. 1317 CONTINUE
  213. C ... Le PRI6 ...
  214. ELSE IF(LETYPE.EQ.16) THEN
  215. DO 1316 IL=1,NBELTS
  216. WRITE(IOPER,1416) NBTEL+IL,NBPID+IEQCOL(IPT1.ICOLOR(IL)),
  217. & (IPT1.NUM(I1,IL),I1=1,6)
  218. 1416 FORMAT('CPENTA ',8I8)
  219. 1316 CONTINUE
  220. C ... Le CU20 ...
  221. ELSE IF(LETYPE.EQ.15) THEN
  222. DO 1315 IL=1,NBELTS
  223. WRITE(IOPER,1415) NBTEL+IL,NBPID+IEQCOL(IPT1.ICOLOR(IL)),
  224. & (IPT1.NUM(CU20(I1),IL),I1= 1, 6),CONTPL,CONTPL,
  225. & (IPT1.NUM(CU20(I1),IL),I1= 7,14),CONTPL,CONTPL,
  226. & (IPT1.NUM(CU20(I1),IL),I1=15,20)
  227. 1415 FORMAT('CHEXA ',8I8,A8,/,A8,8I8,A8,/,A8,6I8)
  228. 1315 CONTINUE
  229. C ... Le CUB8 ...
  230. ELSE IF(LETYPE.EQ.14) THEN
  231. DO 1314 IL=1,NBELTS
  232. WRITE(IOPER,1414) NBTEL+IL,NBPID+IEQCOL(IPT1.ICOLOR(IL)),
  233. & (IPT1.NUM(I1,IL),I1=1,6),CONTPL,CONTPL,
  234. & (IPT1.NUM(I1,IL),I1=7,8)
  235. 1414 FORMAT('CHEXA ',8I8,A8,/,A8,2I8)
  236. 1314 CONTINUE
  237. C ... Le QUA8 (en 3D -> COQ8) ...
  238. ELSE IF(LETYPE.EQ.10) THEN
  239. DO 1310 IL=1,NBELTS
  240. WRITE(IOPER,1410) NBTEL+IL,NBPID+IEQCOL(IPT1.ICOLOR(IL)),
  241. & (IPT1.NUM(QUA8(I1),IL),I1= 1,6),CONTPL,CONTPL,
  242. & (IPT1.NUM(QUA8(I1),IL),I1= 7,8)
  243. 1410 FORMAT('CQUAD8 ',8I8,A8,/,A8,2I8)
  244. 1310 CONTINUE
  245. C ... Le QUA4 (en 3D -> COQ4) ...
  246. ELSE IF(LETYPE.EQ.8) THEN
  247. DO 1308 IL=1,NBELTS
  248. WRITE(IOPER,1408) NBTEL+IL,NBPID+IEQCOL(IPT1.ICOLOR(IL)),
  249. & (IPT1.NUM(I1,IL),I1=1,4)
  250. 1408 FORMAT('CQUAD4 ',6I8)
  251. 1308 CONTINUE
  252. C ... Le TRI6 (en 3D -> COQ6) ...
  253. ELSE IF(LETYPE.EQ.6) THEN
  254. DO 1306 IL=1,NBELTS
  255. WRITE(IOPER,1406) NBTEL+IL,NBPID+IEQCOL(IPT1.ICOLOR(IL)),
  256. & (IPT1.NUM(TRI6(I1),IL),I1=1,6)
  257. 1406 FORMAT('CTRIA6 ',8I8)
  258. 1306 CONTINUE
  259. C ... Le TRI3 (en 3D -> COQ3) ...
  260. ELSE IF(LETYPE.EQ.4) THEN
  261. DO 1304 IL=1,NBELTS
  262. WRITE(IOPER,1404) NBTEL+IL,NBPID+IEQCOL(IPT1.ICOLOR(IL)),
  263. & (IPT1.NUM(I1,IL),I1=1,3)
  264. 1404 FORMAT('CTRIA3 ',5I8)
  265. 1304 CONTINUE
  266. ELSE IF(LETYPE.EQ.2) THEN
  267. DO 1302 IL=1,NBELTS
  268. WRITE(IOPER,1402) NBTEL+IL,NBPID+IEQCOL(IPT1.ICOLOR(IL)),
  269. & (IPT1.NUM(I1,IL),I1=1,2)
  270. 1402 FORMAT('CROD ',4I8)
  271. 1302 CONTINUE
  272. ELSE
  273. WRITE(IOIMP,*) 'Ca ne marche pas encore pour les elements',
  274. & ' de type ',LETYPE,' (',NOMS(LETYPE),')'
  275. ENDIF
  276. NBTEL=NBTEL+NBELTS
  277. NBPID=NBPID+NBCOL
  278. SEGDES IPT1
  279. 1300 CONTINUE
  280. SEGDES MELEME
  281.  
  282. C ... La fin des donnees ...
  283.  
  284. WRITE(IOPER,1500)
  285. 1500 FORMAT('ENDDATA')
  286.  
  287. RETURN
  288. END
  289.  
  290.  
  291.  
  292.  

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