Télécharger la plaquette Cast3M


fr en

Télécharger sornas.eso

Retour à la liste

Numérotation des lignes : 

sornas

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

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