C SORNAS SOURCE CB215821 23/01/25 21:15:36 11573 SUBROUTINE SORNAS CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC C C But : Ecrire un maillage sous forme d'un C BULK DATA de NASTRAN C C Auteur : Michal Bulik C CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER(I-N) -INC PPARAM -INC CCOPTIO -INC CCGEOME -INC SMCOORD -INC SMELEME INTEGER LISCOL(16),IEQCOL(16),NBCOL,NBPID,NBTEL INTEGER CU20(20),PR15(15),TE10(10),QUA8(8),TRI6(6) C INTEGER SEG3(3) REAL*8 YOUNG,NU,RHO,THICKN CHARACTER*8 CONTPL CHARACTER*8 CONTET DATA IEQCOL /0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0/ DATA CU20 /1,3,5,7,13,15,17,19,2,4,6,8,9,10,11,12,14,16,18,20/ DATA PR15 /1,3,5,10,12,14,2,4,6,7,8,9,11,13,15/ DATA TE10 /1,3,5,10,2,4,6,7,8,9/ DATA QUA8 /1,3,5,7,2,4,6,8/ DATA TRI6 /1,3,5,2,4,6/ C DATA SEG3 /1,3,2/ DATA CONTPL /'+ '/ DATA CONTET /'* '/ NBPID=0 NBTEL=0 YOUNG = REAL(2.1D+11) RHO = REAL(7.85D+03) NU = REAL(0.3D+00) CALL LIROBJ('MAILLAGE',MELEME,1,IRETOU) IF(IRETOU.EQ.0) THEN WRITE(IOIMP,8001) 8001 FORMAT('ERREUR dans SORNAS : Pas de maillage trouve !') RETURN ENDIF C ... Si le fichier existe deja, on va l'ecraser ... REWIND IOPER C ... Debut de BULK DATA ... WRITE(IOPER,1000) 1000 FORMAT('BEGIN BULK') C ... Le materiau commun ... WRITE(IOPER,1100) 1,YOUNG,RHO,NU 1100 FORMAT('MAT1 ',I8,1PG8.2,G8.2,G8.2) C ... Les noeuds ... SEGACT,MCOORD IF(IDIM.EQ.2) THEN DO 1200 I=1,NBPTS IPT=(I-1)*(IDIM+1) + 1 WRITE(IOPER,1202) I,0,XCOOR(IPT),XCOOR(IPT+1),CONTET,CONTET, & 0.D0 1200 CONTINUE ELSE IF (IDIM.EQ.3) THEN DO 1210 I=1,NBPTS IPT=(I-1)*(IDIM+1) + 1 WRITE(IOPER,1202) I,0,XCOOR(IPT),XCOOR(IPT+1),CONTET,CONTET, & XCOOR(IPT+2) 1210 CONTINUE ELSE WRITE(IOIMP,8002) 8002 FORMAT('ERREUR dans SORNAS : dimension incorrecte !') ENDIF SEGDES,MCOORD C 1201 FORMAT('GRID ',I8,A8,3(F8.5)) 1202 FORMAT('GRID* ',2I16,2E16.9,A8,/,A8,E16.9) C ... Les connectivites ... SEGACT MELEME NBSOUS=MAX(1,LISOUS(/1)) IPT1=MELEME DO 1300 I=1,NBSOUS IF(LISOUS(/1).GT.0) IPT1=LISOUS(I) SEGACT IPT1 LETYPE=IPT1.ITYPEL NBELTS=IPT1.NUM(/2) C ... Boucle sur les couleurs pour connaitre le nb de nouveaux PID ... C ... Initialisation de IEQCOL (on y met l'equivalence entre les couleurs et les PID) ... NBCOL=1 LISCOL(NBCOL)=IPT1.ICOLOR(1) IEQCOL(IPT1.ICOLOR(1))=NBCOL DO 2000 IL=2,NBELTS DO 2001 IC=1,NBCOL IF(IPT1.ICOLOR(IL).EQ.LISCOL(IC)) GOTO 2000 2001 CONTINUE NBCOL=NBCOL+1 LISCOL(NBCOL)=IPT1.ICOLOR(IL) IEQCOL(IPT1.ICOLOR(IL))=NBCOL 2000 CONTINUE C ... On sort le nombre approprie des PID ... C ... Dans cet IF il faudra rajouter en alternative tous les ITYPEL C des elements SOLIDES, puis creer un autre ELSE IF pour des COQUES, C POUTRES, etc ... IF(LETYPE.EQ.14) THEN DO 2002 IC=1,NBCOL NUMMAT=1 WRITE(IOPER,5001) NBPID+IC,NUMMAT,NBPID+IC 5001 FORMAT('PSOLID ',2I8,48X,'SLD',I5.5) 2002 CONTINUE ELSE IF(LETYPE.EQ.15) THEN DO 2015 IC=1,NBCOL NUMMAT=1 WRITE(IOPER,5004) NBPID+IC,NUMMAT,NBPID+IC 2015 CONTINUE ELSE IF(LETYPE.EQ.16) THEN DO 2005 IC=1,NBCOL NUMMAT=1 WRITE(IOPER,5004) NBPID+IC,NUMMAT,NBPID+IC 5004 FORMAT('PSOLID ',2I8,48X,'SLD',I5.5) 2005 CONTINUE ELSE IF(LETYPE.EQ.17) THEN DO 2017 IC=1,NBCOL NUMMAT=1 WRITE(IOPER,5004) NBPID+IC,NUMMAT,NBPID+IC 2017 CONTINUE ELSE IF(LETYPE.EQ.23) THEN DO 2023 IC=1,NBCOL NUMMAT=1 WRITE(IOPER,5005) NBPID+IC,NUMMAT,NBPID+IC 5005 FORMAT('PSOLID ',2I8,48X,'SLD',I5.5) 2023 CONTINUE ELSE IF(LETYPE.EQ.24) THEN DO 2024 IC=1,NBCOL NUMMAT=1 WRITE(IOPER,5005) NBPID+IC,NUMMAT,NBPID+IC 2024 CONTINUE ELSE IF(LETYPE.EQ.10) THEN DO 2010 IC=1,NBCOL NUMMAT=1 THICKN=REAL(8.0D-2) WRITE(IOPER,5002) NBPID+IC,NUMMAT,THICKN,NBPID+IC 2010 CONTINUE ELSE IF(LETYPE.EQ.8) THEN DO 2003 IC=1,NBCOL NUMMAT=1 THICKN=REAL(1.D0) WRITE(IOPER,5002) NBPID+IC,NUMMAT,THICKN,NBPID+IC 5002 FORMAT('PSHELL ',2I8,G8.2,40X,'SHL',I5.5) 2003 CONTINUE ELSE IF(LETYPE.EQ.6) THEN DO 2006 IC=1,NBCOL NUMMAT=1 THICKN=REAL(6.0D-1) WRITE(IOPER,5003) NBPID+IC,NUMMAT,THICKN,NBPID+IC 2006 CONTINUE ELSE IF(LETYPE.EQ.4) THEN DO 2004 IC=1,NBCOL NUMMAT=1 THICKN=REAL(1.D0) WRITE(IOPER,5003) NBPID+IC,NUMMAT,THICKN,NBPID+IC 5003 FORMAT('PSHELL ',2I8,G8.2,40X,'SHL',I5.5) 2004 CONTINUE ELSE IF(LETYPE.EQ.2) THEN DO 2007 IC=1,NBCOL NUMMAT=1 THICKN=REAL(1.0D-2) WRITE(IOPER,5006) NBPID+IC,NUMMAT,THICKN,NBPID+IC 5006 FORMAT('PROD ',2I8,G8.2,40X,'ROD',I5.5) 2007 CONTINUE ENDIF C ... Ecriture des conectivites ... C ... Le TET4 ... IF(LETYPE.EQ.23) THEN DO 1323 IL=1,NBELTS WRITE(IOPER,1423) NBTEL+IL,NBPID+IEQCOL(IPT1.ICOLOR(IL)), & (IPT1.NUM(I1,IL),I1=1,4) 1423 FORMAT('CTETRA ',6I8) 1323 CONTINUE C ... Le TE10 ... ELSE IF(LETYPE.EQ.24) THEN DO 1324 IL=1,NBELTS WRITE(IOPER,1424) NBTEL+IL,NBPID+IEQCOL(IPT1.ICOLOR(IL)), & (IPT1.NUM(TE10(I1),IL),I1= 1, 6),CONTPL,CONTPL, & (IPT1.NUM(TE10(I1),IL),I1= 7,10) 1424 FORMAT('CTETRA ',8I8,A8,/,A8,4I8) 1324 CONTINUE C ... Le PR15 ... ELSE IF(LETYPE.EQ.17) THEN DO 1317 IL=1,NBELTS WRITE(IOPER,1417) NBTEL+IL,NBPID+IEQCOL(IPT1.ICOLOR(IL)), & (IPT1.NUM(PR15(I1),IL),I1= 1, 6),CONTPL,CONTPL, & (IPT1.NUM(PR15(I1),IL),I1= 7,14),CONTPL,CONTPL, & (IPT1.NUM(PR15(I1),IL),I1=15,15) 1417 FORMAT('CPENTA ',8I8,A8,/,A8,8I8,A8,/,A8,1I8) 1317 CONTINUE C ... Le PRI6 ... ELSE IF(LETYPE.EQ.16) THEN DO 1316 IL=1,NBELTS WRITE(IOPER,1416) NBTEL+IL,NBPID+IEQCOL(IPT1.ICOLOR(IL)), & (IPT1.NUM(I1,IL),I1=1,6) 1416 FORMAT('CPENTA ',8I8) 1316 CONTINUE C ... Le CU20 ... ELSE IF(LETYPE.EQ.15) THEN DO 1315 IL=1,NBELTS WRITE(IOPER,1415) NBTEL+IL,NBPID+IEQCOL(IPT1.ICOLOR(IL)), & (IPT1.NUM(CU20(I1),IL),I1= 1, 6),CONTPL,CONTPL, & (IPT1.NUM(CU20(I1),IL),I1= 7,14),CONTPL,CONTPL, & (IPT1.NUM(CU20(I1),IL),I1=15,20) 1415 FORMAT('CHEXA ',8I8,A8,/,A8,8I8,A8,/,A8,6I8) 1315 CONTINUE C ... Le CUB8 ... ELSE IF(LETYPE.EQ.14) THEN DO 1314 IL=1,NBELTS WRITE(IOPER,1414) NBTEL+IL,NBPID+IEQCOL(IPT1.ICOLOR(IL)), & (IPT1.NUM(I1,IL),I1=1,6),CONTPL,CONTPL, & (IPT1.NUM(I1,IL),I1=7,8) 1414 FORMAT('CHEXA ',8I8,A8,/,A8,2I8) 1314 CONTINUE C ... Le QUA8 (en 3D -> COQ8) ... ELSE IF(LETYPE.EQ.10) THEN DO 1310 IL=1,NBELTS WRITE(IOPER,1410) NBTEL+IL,NBPID+IEQCOL(IPT1.ICOLOR(IL)), & (IPT1.NUM(QUA8(I1),IL),I1= 1,6),CONTPL,CONTPL, & (IPT1.NUM(QUA8(I1),IL),I1= 7,8) 1410 FORMAT('CQUAD8 ',8I8,A8,/,A8,2I8) 1310 CONTINUE C ... Le QUA4 (en 3D -> COQ4) ... ELSE IF(LETYPE.EQ.8) THEN DO 1308 IL=1,NBELTS WRITE(IOPER,1408) NBTEL+IL,NBPID+IEQCOL(IPT1.ICOLOR(IL)), & (IPT1.NUM(I1,IL),I1=1,4) 1408 FORMAT('CQUAD4 ',6I8) 1308 CONTINUE C ... Le TRI6 (en 3D -> COQ6) ... ELSE IF(LETYPE.EQ.6) THEN DO 1306 IL=1,NBELTS WRITE(IOPER,1406) NBTEL+IL,NBPID+IEQCOL(IPT1.ICOLOR(IL)), & (IPT1.NUM(TRI6(I1),IL),I1=1,6) 1406 FORMAT('CTRIA6 ',8I8) 1306 CONTINUE C ... Le TRI3 (en 3D -> COQ3) ... ELSE IF(LETYPE.EQ.4) THEN DO 1304 IL=1,NBELTS WRITE(IOPER,1404) NBTEL+IL,NBPID+IEQCOL(IPT1.ICOLOR(IL)), & (IPT1.NUM(I1,IL),I1=1,3) 1404 FORMAT('CTRIA3 ',5I8) 1304 CONTINUE ELSE IF(LETYPE.EQ.2) THEN DO 1302 IL=1,NBELTS WRITE(IOPER,1402) NBTEL+IL,NBPID+IEQCOL(IPT1.ICOLOR(IL)), & (IPT1.NUM(I1,IL),I1=1,2) 1402 FORMAT('CROD ',4I8) 1302 CONTINUE ELSE WRITE(IOIMP,*) 'Ca ne marche pas encore pour les elements', & ' de type ',LETYPE,' (',NOMS(LETYPE),')' ENDIF NBTEL=NBTEL+NBELTS NBPID=NBPID+NBCOL SEGDES IPT1 1300 CONTINUE SEGDES MELEME C ... La fin des donnees ... WRITE(IOPER,1500) 1500 FORMAT('ENDDATA') RETURN END