Télécharger la plaquette Cast3M


fr en

Télécharger soraba.eso

Retour à la liste

Numérotation des lignes : 

soraba

  1. C SORABA    SOURCE    FANDEUR   22/03/10    21:15:04     11313          
  2. ************************************************************************
  3. * NOM         : soraba.eso
  4. * DESCRIPTION : Sortie d'un maillage au format .inp ABAQUS(TM)
  5. ************************************************************************
  6. * HISTORIQUE :  8/01/2010 : FANDEUR : création de la subroutine
  7. * HISTORIQUE :  7/06/2012 : JCARDO : l'argument MOT1 devient optionnel
  8. *                                    + ajout de l'extension .inp
  9. * HISTORIQUE :
  10. ************************************************************************
  11. * Prière de PRENDRE LE TEMPS DE COMPLÉTER LES COMMENTAIRES
  12. * en cas de modification de ce sous-programme afin de faciliter
  13. * la maintenance !
  14. ************************************************************************
  15. * APPELÉ PAR : opérateur SORTir (prsort.eso)
  16. ************************************************************************
  17. * ENTRÉES :: aucune
  18. * SORTIES :: aucune (sur fichier uniquement)
  19. ************************************************************************
  20. * SYNTAXE (GIBIANE) :
  21. *
  22. *    SORT 'ABAQ' MAIL1
  23. *
  24. ************************************************************************
  25.  
  26.       SUBROUTINE SORABA
  27.  
  28.       IMPLICIT INTEGER(I-N)
  29.       IMPLICIT REAL*8(A-H,O-Z)
  30.  
  31. -INC PPARAM
  32. -INC CCOPTIO
  33.  
  34. -INC SMCOORD
  35. -INC SMELEME
  36. -INC SMINTE
  37. -INC SMLENTI
  38.       SEGMENT MLISEF.MLENTI
  39. -INC TMLNOMS
  40.  
  41.       SEGMENT MCHAEF
  42.         CHARACTER*16 LCHA16(MEF)
  43.       ENDSEGMENT
  44.  
  45.       SEGMENT ITAB(0)
  46.       POINTEUR ITAB1.ITAB
  47.  
  48.       SEGMENT IMAIL
  49.         INTEGER I_OBJ(NBMAIL),I_MAI(NBMAIL),L_OBJ(NBMAIL)
  50.         CHARACTER*16 C_OBJ(NBMAIL)
  51.       ENDSEGMENT
  52.  
  53.       SEGMENT MWRK
  54.         INTEGER NOEELT(nbno)
  55.         REAL*8 XEL(3,nbno)
  56.       ENDSEGMENT
  57.  
  58.       EXTERNAL LONG
  59.  
  60.       CHARACTER*16 CHA16z,CODEEF
  61.  
  62. C= Nombre d'informations par maillage elementaire dans MLISEF
  63.       PARAMETER (IN_EF=3)
  64.  
  65. C= Unite logique du fichier d'impression au format Abaqus(TM)
  66.       PARAMETER (IUABA=66)
  67.       CHARACTER*(LOCHAI) FICABA
  68.       LOGICAL ZOPEN
  69.  
  70. C= Base de conversion des elements MASSIFS Cast3m vers Abaqus
  71.       PARAMETER (NNOMAX=20,NEFMAX=12)
  72.       DIMENSION lTypEF(NEFMAX),
  73.      &          lInver(NNOMAX,NEFMAX),lOrdre(NNOMAX,NEFMAX)
  74.       CHARACTER*6 NomAba(NEFMAX)
  75.  
  76. C= Element :          SEG2     SEG3     TRI3     QUA4     TRI6
  77. C=                    QUA8     TET4     PRI6     CUB8     TE10
  78. C=                    PR15     CU20
  79.       DATA lTypEF /        2,       3,       4,       8,       6,
  80.      &                    10,      23,      16,      14,      24,
  81.      &                    17,      15 /
  82.       DATA ((lInver(j,i),j=1,NNOMAX),i=1,NEFMAX)
  83.      &  / 2, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  84.      &    3, 2, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  85.      &    1, 3, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  86.      &    1, 4, 3, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  87.      &    1, 6, 5, 4, 3, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  88.      &    1, 8, 7, 6, 5, 4, 3, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  89.      &    1, 3, 2, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  90.      &    4, 5, 6, 1, 2, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  91.      &    5, 6, 7, 8, 1, 2, 3, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  92.      &    1, 7,10, 9, 5, 6, 2, 8, 4, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  93.      &   10,11,12,13,14,15, 7, 8, 9, 1, 2, 3, 4, 5, 6, 0, 0, 0, 0, 0,
  94.      &   13,14,15,16,17,18,19,20, 9,10,11,12, 1, 2, 3, 4, 5, 6, 7, 8 /
  95.       DATA ((lOrdre(j,i),j=1,NNOMAX),i=1,NEFMAX)
  96.      &  / 1, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  97.      &    1, 3, 2, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  98.      &    1, 2, 3, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  99.      &    1, 2, 3, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  100.      &    1, 3, 5, 2, 4, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  101.      &    1, 3, 5, 7, 2, 4, 6, 8, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  102.      &    1, 2, 3, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  103.      &    1, 2, 3, 4, 5, 6, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  104.      &    1, 2, 3, 4, 5, 6, 7, 8, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  105.      &    1, 3, 5,10, 2, 4, 6, 7, 8, 9, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
  106.      &    1, 3, 5,10,12,14, 2, 4, 6,11,13,15, 7, 8, 9, 0, 0, 0, 0, 0,
  107.      &    1, 3, 5, 7,13,15,17,19, 2, 4, 6, 8,14,16,18,20, 9,10,11,12 /
  108.       DATA NomAba / '____  ','____  ','C__3  ','C__4  ','C__6  ',
  109.      &              'C__8  ','C3D4  ','C3D6  ','C3D8  ','C3D10 ',
  110.      &              'C3D15 ','C3D20 ' /
  111.  
  112. C===
  113. C 0 - Premieres initialisations
  114. C===
  115.       idimp1=IDIM+1
  116. C= Liste des elements MASSIFS qui sont sauvegardes (suivant IDIM)
  117.       IF (IDIM.EQ.3) THEN
  118.         I_DEB=7
  119.         I_FIN=12
  120.       ELSE IF (IDIM.EQ.2) THEN
  121.         I_DEB=3
  122.         I_FIN=6
  123.         IF (IFOUR.EQ.-2) THEN
  124.           DO i=I_DEB,I_FIN
  125.             NomAba(i)(2:3)='PS'
  126.           ENDDO
  127.         ELSE IF (IFOUR.GE.0) THEN
  128.           DO i=I_DEB,I_FIN
  129.             NomAba(i)(2:3)='AX'
  130.           ENDDO
  131.         ELSE
  132.           DO i=I_DEB,I_FIN
  133.             NomAba(i)(2:3)='PE'
  134.           ENDDO
  135.         ENDIF
  136.       ELSE IF (IDIM.EQ.1) THEN
  137.         I_DEB=1
  138.         I_FIN=2
  139.       ELSE
  140.         CALL ERREUR(832)
  141.         RETURN
  142.       ENDIF
  143. C En cas d erreur sur le fichier de sortie (si non nul)
  144.       IOS=0
  145.  
  146. C===
  147. C 1 - Lecture des arguments (obligatoires)
  148. C===
  149. C Lecture du maillage a sauvegarder
  150.       CALL LIROBJ('MAILLAGE',MAIREF,1,IRETOU)
  151.       IF (IERR.NE.0) RETURN
  152. *
  153. C     Lecture du nom du fichier de sauvegarde (=> bypass de OPTI SORT)
  154. C     (CONSERVE POUR COMPATIBILITE MAIS NON DOCUMENTE)
  155.       CALL LIRCHA(FICABA,0,IRETOU)
  156.       IF (IRETOU.EQ.0) THEN
  157.           INQUIRE(UNIT=IOPER,OPENED=ZOPEN)
  158.           IF (.NOT.ZOPEN) THEN
  159.               CALL ERREUR(-212)
  160.               WRITE(IOIMP,*) '(via OPTI "SORT")'
  161.               MOTERR(1:8)='ABAQUS  '
  162.               CALL ERREUR(705)
  163.               RETURN
  164.           ENDIF
  165.           INQUIRE(UNIT=IOPER,NAME=FICABA)
  166.           CLOSE(UNIT=IOPER,STATUS='DELETE')
  167. *
  168. *         Ajout de l'extension au nom du fichier
  169.           CALL LENCHA(FICABA,LC)
  170.           IF ((FICABA(LC-3:LC).NE.'.inp') .AND.
  171.      &        (FICABA(LC-3:LC).NE.'.INP')      ) THEN
  172.             IF (LC+4.GT.LOCHAI) THEN
  173.               write(ioimp,*) 'ABAQUS File name too long with extension'
  174.               CALL ERREUR(1111)
  175.               RETURN
  176.             ENDIF
  177.             FICABA(LC+1:LC+4)='.inp'
  178.           ENDIF
  179.       ENDIF
  180.  
  181. C= Prevoir des options supplementaires ?
  182.  
  183.       WRITE(IOIMP,*)
  184. C===
  185. C 2 - Analyse de l objet MAILLAGE a sauvegarder
  186. C===
  187.       WRITE(IOIMP,500) 'Analyse du MAILLAGE a sauvegarder'
  188. C Verification du type des elements du maillage
  189. C Determination du nombre d'elements du maillage
  190.       MELEME=MAIREF
  191.       SEGACT,MELEME
  192.       NB_OBJ=LISOUS(/1)
  193.       NB_EF=MAX(1,NB_OBJ)
  194.       JG=IN_EF*NB_EF
  195.       SEGINI,MLISEF
  196.       MEF=NB_EF
  197.       SEGINI,MCHAEF
  198.       CODEEF='0000000000000000'
  199.       NB_ELT=0
  200.       IF (NB_OBJ.EQ.0) THEN
  201.         i_z=ITYPEL
  202.         DO i=I_DEB,I_FIN
  203.           IF (i_z.EQ.lTypEF(i)) GOTO 1
  204.         ENDDO
  205.         CALL ERREUR(16)
  206.         GOTO 900
  207.  1      CONTINUE
  208.         MLISEF.LECT(1)=MELEME
  209.         MLISEF.LECT(2)=i
  210.         MLISEF.LECT(3)=NB_ELT
  211.         MCHAEF.LCHA16(1)='EF_'//NomAba(i)
  212.         CODEEF(1:1)='1'
  213.         NB_ELT=NB_ELT+NUM(/2)
  214.       ELSE
  215.         k=1
  216.         DO j=1,NB_OBJ
  217.           IPT1=LISOUS(j)
  218.           SEGACT,IPT1
  219.           i_z=IPT1.ITYPEL
  220.           DO i=I_DEB,I_FIN
  221.             IF (i_z.EQ.lTypEF(i)) GOTO 2
  222.           ENDDO
  223.           CALL ERREUR(16)
  224.           GOTO 900
  225.  2        CONTINUE
  226.           MLISEF.LECT(k)=IPT1
  227.           MLISEF.LECT(k+1)=i
  228.           MLISEF.LECT(k+2)=NB_ELT
  229.           MCHAEF.LCHA16(j)='EF_'//NomAba(i)
  230.           CODEEF(j:j)='1'
  231.           NB_ELT=NB_ELT+IPT1.NUM(/2)
  232.           k=k+IN_EF
  233.         ENDDO
  234.       ENDIF
  235. C*I   WRITE(IOIMP,501) 'Type EF =',NB_EF
  236. C Appel a TASSER pour mettre les noeuds a sauvegarder en premier
  237.       WRITE(IOIMP,502) 'Appel a TASSER (etape longue)'
  238.       SEGINI,ITAB
  239.       ITAB(**)=MAIREF
  240.       MELEME=MAIREF
  241.       IF (NB_OBJ.NE.0) THEN
  242.         DO i=1,NB_OBJ
  243.           ITAB(**)=LISOUS(i)
  244.         ENDDO
  245.       ENDIF
  246.       ipt8=0
  247.       CALL TASSPO(ITAB,ICOLAC,ipt8,0,1)
  248.       IF (ipt8.GT.0) SEGSUP,ipt8
  249.       IF (IERR.NE.0) THEN
  250.         SEGSUP,ITAB
  251.         GOTO 900
  252.       ENDIF
  253.       SEGINI,ITAB1=ITAB
  254.       CALL SUPPIL(ICOLAC,-1)
  255. C= ITAB a ete supprime apres l'appel a SUPPIL.
  256.       ITAB=ITAB1
  257.       IF (IERR.NE.0) THEN
  258.         SEGSUP,ITAB
  259.         GOTO 900
  260.       ENDIF
  261. C= Suite a l'appel a TASSER, les points sont classes en commencant par
  262. C= ceux associes au MAILLAGE qui nous interesse. Il suffit de trouver
  263. C= le noeud de numero max. dans le MAILLAGE.
  264.       WRITE(IOIMP,502) 'Determination du numero du noeud max.'
  265.       IMAX=0
  266.       DO i=1,NB_EF
  267.         MELEME=MLISEF.LECT(IN_EF*(i-1)+1)
  268.         SEGACT,MELEME
  269.         nbnn=NUM(/1)
  270.         DO j=1,NUM(/2)
  271.           DO k=1,nbnn
  272.             IMAX=MAX(IMAX,NUM(k,j))
  273.           ENDDO
  274.         ENDDO
  275.         SEGDES,MELEME
  276.       ENDDO
  277. C*I   WRITE(IOIMP,501) 'Numero du noeud max. =',IMAX
  278. C Liste des objets MAILLAGEs eventuellement a sauvegarder (IMAIL)
  279. C= En sortie de TASSPO, ITAB a ete modifie et pointe sur tous les
  280. C= maillages references dans le MAILLAGE a sauvegarder.
  281.       WRITE(IOIMP,502) 'Construction de la liste des maillages a sauver'
  282. C Rajout de tous les maillages elementaires dans ITAB non deja listes
  283.       DO i=1,ITAB(/1)
  284.         MELEME=ITAB(i)
  285.         SEGACT,MELEME
  286.         j=LISOUS(/1)
  287.         IF (j.NE.0) THEN
  288.           DO k=1,j
  289.             IPT1=LISOUS(k)
  290.             DO l=1,ITAB(/1)
  291.               IF (IPT1.EQ.ITAB(l)) GOTO 3
  292.             ENDDO
  293.             ITAB(**)=IPT1
  294.  3          CONTINUE
  295.           ENDDO
  296.         ENDIF
  297.         SEGDES,MELEME
  298.       ENDDO
  299. C   Analyse de tous les maillages elementaires
  300. C + Determination des groupes de noeuds
  301. C= Ne sont conserves que les maillages dont le type correspond
  302. C= a ceux du MAILLAGE a sauver et les maillages de type POI1.
  303.       DO i=1,ITAB(/1)
  304.         MELEME=ITAB(i)
  305.         SEGACT,MELEME
  306.         IF (LISOUS(/1).NE.0) GOTO 11
  307.         IF (ITYPEL.EQ.1) GOTO 10
  308.         DO j=1,IN_EF*NB_EF,IN_EF
  309.           IF (MELEME.EQ.MLISEF.LECT(j)) GOTO 11
  310.           IF (ITYPEL.EQ.lTypEF(MLISEF.LECT(j+1))) GOTO 10
  311.         ENDDO
  312. C*I   WRITE(ioimp,*) 'Maillage',i,MELEME,'type EF pas ok',ITYPEL
  313.         ITAB(i)=0
  314.         GOTO 11
  315.  10     CONTINUE
  316.         nbnn=NUM(/1)
  317.         nbel=NUM(/2)
  318.         DO j=1,nbel
  319.           DO k=1,nbnn
  320.             IF (NUM(k,j).GT.IMAX) THEN
  321. C*I   write(ioimp,*) 'Maillage avec noe > IMAX',i,MELEME
  322.               ITAB(i)=0
  323.               GOTO 11
  324.             ENDIF
  325.           ENDDO
  326.         ENDDO
  327.         IF (ITYPEL.EQ.1) ITAB(i)=-MELEME
  328.  11     CONTINUE
  329.         SEGDES,MELEME
  330.       ENDDO
  331. C ReAnalyse de tous les maillages complexes
  332. C= Les maillages de POI1 ne sont jamais complexes !
  333.       DO i=1,ITAB(/1)
  334.         MELEME=ITAB(i)
  335.         IF (MELEME.LE.0) GOTO 20
  336.         SEGACT,MELEME
  337.         j=LISOUS(/1)
  338.         IF (j.EQ.0) GOTO 21
  339.         DO k=1,j
  340.           IPT1=LISOUS(k)
  341.           DO l=1,ITAB(/1)
  342.             IF (IPT1.EQ.ITAB(l)) GOTO 22
  343.           ENDDO
  344. C*I   write(ioimp,*) 'Maillage complexe sousref pas OK',i,k,IPT1
  345.           ITAB(i)=0
  346.           GOTO 21
  347.  22       CONTINUE
  348.         ENDDO
  349.  21     CONTINUE
  350.         SEGDES,MELEME
  351.  20     CONTINUE
  352.       ENDDO
  353. C Liste des objets a considerer pour la sauvegarde (IMAIL)
  354.       NBMAIL=0
  355.       DO i=1,ITAB(/1)
  356.         IF (ITAB(i).NE.0) NBMAIL=NBMAIL+1
  357.       ENDDO
  358. C*I   WRITE(IOIMP,*) 'NBMAIL=',NBMAIL,ITAB(/1)
  359.       SEGINI,IMAIL
  360.       j=0
  361.       CHA16z='0000000000000000'
  362.       DO i=1,ITAB(/1)
  363.         k=ITAB(i)
  364.         IF (k.NE.0) THEN
  365.           j=j+1
  366.           I_OBJ(j)=4
  367.           IF (k.LT.0) I_OBJ(j)=1
  368.           I_MAI(j)=ABS(k)
  369.           C_OBJ(j)='                '
  370.           DO l=1,NB_EF
  371.             m=IN_EF*(l-1)+1
  372.             IF (k.EQ.MLISEF.LECT(m)) THEN
  373.               I_OBJ(j)=2
  374.               L_OBJ(j)=-l
  375.               C_OBJ(j)=MCHAEF.LCHA16(l)
  376.               CHA16z(l:l)='1'
  377.             ENDIF
  378.           ENDDO
  379.         ENDIF
  380.       ENDDO
  381.       SEGSUP,ITAB
  382.       IF (j.NE.NBMAIL) write(ioimp,*) '=> probleme !'
  383.       IF (CHA16z.NE.CODEEF) THEN
  384.         WRITE(IOIMP,510) 'codage incorrect'
  385.         GOTO 901
  386.       ENDIF
  387. C Poursuite de l'analyse des maillages elementaires
  388. C= Verification et remplissage de IMAIL
  389.       JMAX=IMAX+1
  390.       JG=JMAX
  391.       SEGINI,MLENTI
  392.       i_z=0
  393.       DO i=1,NB_EF
  394.         MELEME=MLISEF.LECT(i_z+1)
  395.         SEGACT,MELEME
  396.         nbnn=NUM(/1)
  397.         nbel=NUM(/2)
  398.         DO j=1,nbel
  399.           DO k=1,nbnn
  400.             j_z=NUM(k,j)
  401.             LECT(j_z)=LECT(j_z)+1
  402.           ENDDO
  403.         ENDDO
  404.         DO j=2,IMAX
  405.           LECT(j)=LECT(j)+LECT(j-1)
  406.         ENDDO
  407.         JG=LECT(IMAX)
  408.         LECT(JMAX)=JG
  409.         SEGINI,MLENT1
  410.         DO j=1,nbel
  411.           DO k=1,nbnn
  412.             j_z=NUM(k,j)
  413.             k_z=LECT(j_z)
  414.             MLENT1.LECT(k_z)=j
  415.             LECT(j_z)=LECT(j_z)-1
  416.           ENDDO
  417.         ENDDO
  418.         NumEF=MLISEF.LECT(i_z+3)
  419.         DO j=1,NBMAIL
  420.           IF (I_OBJ(j).LT.3) GOTO 30
  421.           IPT1=I_MAI(j)
  422.           IF (IPT1.EQ.MELEME) GOTO 30
  423.           SEGACT,IPT1
  424.           IF (IPT1.ITYPEL.NE.ITYPEL) GOTO 31
  425.           nbnn=IPT1.NUM(/1)
  426.           nbel=IPT1.NUM(/2)
  427.           JG=nbel
  428.           SEGINI,MLENT2
  429.           j_z=0
  430.           DO iel1=1,nbel
  431.             iel=IPT1.NUM(1,iel1)
  432.             ideb=LECT(iel)+1
  433.             ifin=LECT(iel+1)
  434.             IF (ifin.LT.ideb) GOTO 32
  435.             DO k=ideb,ifin
  436.               iel=MLENT1.LECT(k)
  437.               DO l=1,nbnn
  438.                 IF (NUM(l,iel).NE.IPT1.NUM(l,iel1)) GOTO 34
  439.               ENDDO
  440.               j_z=j_z+1
  441.               MLENT2.LECT(j_z)=NumEF+iel
  442.               GOTO 33
  443.  34           CONTINUE
  444.             ENDDO
  445. C*I   write(ioimp,*) 'elt du maillage pas ds mlisef',j,IPT1,iel1,i
  446.             GOTO 32
  447.  33         CONTINUE
  448.           ENDDO
  449.  32       CONTINUE
  450.           IF (j_z.NE.nbel) THEN
  451.             I_OBJ(j)=0
  452.             SEGSUP,MLENT2
  453. C*I   write(ioimp,*) 'Mail',j,I_OBJ(j),' = non sauve'
  454.           ELSE IF (j_z.EQ.NUM(/2)) THEN
  455.             I_OBJ(j)=2
  456.             L_OBJ(j)=-i
  457.             SEGSUP,MLENT2
  458. C*I   write(ioimp,*) 'Mail.',j,I_OBJ(j),'=Mail.EF',L_OBJ(j)
  459.           ELSE
  460.             I_OBJ(j)=3
  461.             L_OBJ(j)=MLENT2
  462.             SEGDES,MLENT2
  463. C*I   write(ioimp,*) 'Mail.',j,I_OBJ(j),'=Mail.elem',L_OBJ(j)
  464.           ENDIF
  465.  31       CONTINUE
  466.           SEGDES,IPT1
  467.  30       CONTINUE
  468.         ENDDO
  469.         SEGSUP,MLENT1
  470.         SEGDES,MELEME
  471.         i_z=i_z+IN_EF
  472. C= Ne pas oublier de remettre a zero MLENTI pour le type EF suivant
  473.         IF (NB_EF.NE.1) THEN
  474.           DO j=1,JMAX
  475.             LECT(j)=0
  476.           ENDDO
  477.         ENDIF
  478.       ENDDO
  479.       SEGSUP,MLENTI
  480. C   ReAnalyse de tous les maillages complexes
  481. C + Fin du remplissage de IMAIL
  482.       DO i=1,NBMAIL
  483.         IF (I_OBJ(i).NE.4) GOTO 40
  484.         MELEME=I_MAI(i)
  485.         SEGACT,MELEME
  486.         JG=LISOUS(/1)
  487.         IF (JG.EQ.0) THEN
  488. C*I   write(ioimp,*) 'Bizarre I_OBJ=4 et LISOUS(/1)=0 pour ITAB',i
  489.           GOTO 41
  490.         ENDIF
  491.         SEGINI,MLENTI
  492.         L_OBJ(i)=MLENTI
  493.         DO j=1,JG
  494.           IPT1=LISOUS(j)
  495.           DO k=1,NBMAIL
  496.             IF (IPT1.EQ.I_MAI(k)) GOTO 42
  497.           ENDDO
  498. C*I   write(ioimp,*) 'Maillage complexe sousref pas OK',i,k,IPT1
  499.           I_OBJ(i)=0
  500.           L_OBJ(i)=0
  501.           SEGSUP,MLENTI
  502.           GOTO 41
  503.  42       CONTINUE
  504.           LECT(j)=k
  505.         ENDDO
  506.  41     CONTINUE
  507. C*I   write(ioimp,*) 'Mail.complexe',i,I_OBJ(i),L_OBJ(i)
  508.         SEGDES,MELEME
  509.  40     CONTINUE
  510.       ENDDO
  511. C Recuperation des MAILLAGEs nommes
  512.       i_z=0
  513.       CALL REPERT('MAILLAGE',i_z)
  514.       IF (i_z.GT.0) THEN
  515.         CALL REPLIS('MAILLAGE',MLNOMS)
  516.         SEGACT,MLNOMS
  517.         DO i=1,i_z
  518.           CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
  519.           IF (IERR.NE.0) THEN
  520.             SEGSUP,MLNOMS
  521.             GOTO 901
  522.           ENDIF
  523.           DO j=1,NB_EF
  524.             IF (IPT1.EQ.MLISEF.LECT(IN_EF*(j-1)+1))
  525.      &        MCHAEF.LCHA16(j)=LINOMS(i)(1:16)
  526.           ENDDO
  527.           DO j=1,NBMAIL
  528.             IF (IPT1.EQ.I_MAI(j)) C_OBJ(j)=LINOMS(i)(1:16)
  529.           ENDDO
  530.         ENDDO
  531.         SEGSUP,MLNOMS
  532.       ENDIF
  533. C Nom par defaut pour les maillages non nommes
  534.       j=0
  535.       iel=0
  536.       DO i=1,NBMAIL
  537.         IF (C_OBJ(i)(1:4).EQ.'    ') THEN
  538.           IF (I_OBJ(i).EQ.1) THEN
  539.             j=j+1
  540.             C_OBJ(i)(1:4)='Noe_'
  541.             WRITE(C_OBJ(i)(5:8),FMT='(I4.4)') j
  542.           ELSE IF (I_OBJ(i).GE.3) THEN
  543.             iel=iel+1
  544.             C_OBJ(i)(1:4)='Elt_'
  545.             WRITE(C_OBJ(i)(5:8),FMT='(I4.4)') iel
  546.           ENDIF
  547.         ENDIF
  548.       ENDDO
  549. C Determination du nombre de groupe de noeuds et de groupe d'elements
  550.       NB_GNO=0
  551.       NB_GEL=0
  552.       DO i=1,NBMAIL
  553.         IF (I_OBJ(i).EQ.1) THEN
  554.           NB_GNO=NB_GNO+1
  555.         ELSE IF (I_OBJ(i).EQ.2) THEN
  556.           IF (C_OBJ(i).NE.MCHAEF.LCHA16(-L_OBJ(i))) NB_GEL=NB_GEL+1
  557.         ELSE IF (I_OBJ(i).EQ.3) THEN
  558.           NB_GEL=NB_GEL+1
  559.         ELSE IF (I_OBJ(i).EQ.4) THEN
  560.           NB_GEL=NB_GEL+1
  561.           MLENTI=L_OBJ(i)
  562.           k=0
  563.           DO j=1,LECT(/1)
  564.             j_z=I_OBJ(LECT(j))
  565.             IF (j_z.EQ.2.OR.j_z.EQ.3) k=k+1
  566.           ENDDO
  567.           IF (k.NE.LECT(/1)) THEN
  568.             WRITE(IOIMP,510) 'ANORMALE (50)'
  569.             GOTO 901
  570.           ENDIF
  571.         ENDIF
  572.  50     CONTINUE
  573.       ENDDO
  574.  
  575. C===
  576. C 3 - Ecriture dans le fichier de sortie au format Abaqus(R)
  577. C===
  578. C Ouverture du fichier au format Abaqus(R)
  579.       WRITE(IOIMP,500) 'Ouverture du fichier au format Abaqus(R)'
  580.       IOS=1
  581.       CLOSE(UNIT=IUABA,ERR=901)
  582.       IOS=0
  583.       OPEN(UNIT=IUABA,STATUS='UNKNOWN',FILE=FICABA(1:LONG(FICABA)),
  584.      &     IOSTAT=IOS,FORM='FORMATTED')
  585.       IF (IOS.NE.0) GOTO 901
  586. C Ecriture entete (a completer)
  587.       WRITE(IOIMP,502) 'Ecriture de l entete du fichier'
  588.       WRITE(IUABA,800) '****'
  589. C Ecriture des noeuds du maillage
  590.       WRITE(IOIMP,502) 'Ecriture des noeuds du maillage'
  591.       WRITE(IUABA,800) '** DEFINITION DES NOEUDS DU MAILLAGE'
  592.       WRITE(IUABA,800) '****'
  593.       WRITE(IUABA,800) '*NODE, SYSTEM=R'
  594.       IF (IDIM.EQ.3) THEN
  595.         DO i=1,IMAX
  596.           j=idimp1*(i-1)
  597.           WRITE(IUABA,FMT=810) i,XCOOR(j+1),XCOOR(j+2),XCOOR(j+3)
  598.         ENDDO
  599.       ELSE IF (IDIM.EQ.2) THEN
  600.         DO i=1,IMAX
  601.           j=idimp1*(i-1)
  602.           WRITE(IUABA,FMT=811) i,XCOOR(j+1),XCOOR(j+2)
  603.         ENDDO
  604.       ELSE
  605.         DO i=1,IMAX
  606.           j=idimp1*(i-1)
  607.           WRITE(IUABA,FMT=812) i,XCOOR(j+1)
  608.         ENDDO
  609.       ENDIF
  610.       WRITE(IUABA,800) '****'
  611.       WRITE(IOIMP,501) 'Nombre de noeuds =',IMAX
  612. C Ecriture des points nommes (un seul noeud)
  613. C Construction de la table des points nommes existants
  614.       WRITE(IOIMP,502) 'Ecriture des points nommes'
  615.       I_PTS=0
  616.       CALL REPERT('POINT   ',I_PTS)
  617.       IF (I_PTS.NE.0) THEN
  618.         WRITE(IUABA,800) '** DEFINITION DES NOEUDS NOMMES'
  619.         WRITE(IUABA,800) '****'
  620.         CALL REPLIS('POINT   ',MLNOMS)
  621.         SEGACT,MLNOMS
  622.         DO i=1,I_PTS
  623.           CALL LIROBJ('POINT   ',IP1,1,IRETOU)
  624.           IF (IERR.NE.0) THEN
  625.             SEGSUP,MLNOMS
  626.             GOTO 902
  627.           ENDIF
  628.           IF (IP1.GE.1 .AND. IP1.LE.IMAX) THEN
  629.             WRITE(IUABA,820) LINOMS(i)(1:LONG(LINOMS(i)))
  630.             WRITE(IUABA,821) IP1
  631.           ENDIF
  632.         ENDDO
  633.         SEGSUP,MLNOMS
  634.         WRITE(IUABA,800) '****'
  635.       ENDIF
  636.       WRITE(IOIMP,501) 'Nombre de noeuds nommes =',I_PTS
  637. C Ecriture des groupes de noeuds
  638. C= NSET au sens Abaqus et maillage de type POI1 au sens Cast3m
  639.       WRITE(IOIMP,502) 'Ecriture des groupes de noeuds'
  640.       IF (NB_GNO.NE.0) THEN
  641.         WRITE(IUABA,800) '** DEFINITION DES GROUPES DE NOEUDS'
  642.         WRITE(IUABA,800) '****'
  643.         DO i=1,NBMAIL
  644.           IF (I_OBJ(i).EQ.1) THEN
  645.             MELEME=I_MAI(i)
  646.             SEGACT,MELEME
  647.             WRITE(IUABA,820) C_OBJ(i)(1:LONG(C_OBJ(i)))
  648.             WRITE(IUABA,822) (NUM(1,k),k=1,NUM(/2))
  649.             SEGDES,MELEME
  650.           ENDIF
  651.         ENDDO
  652.         WRITE(IUABA,800) '****'
  653.       ENDIF
  654.       WRITE(IOIMP,501) 'Nombre de groupe de noeuds =',NB_GNO
  655. C Ecriture des differents elements
  656.       WRITE(IOIMP,502) 'Ecriture des elements du maillage'
  657.       WRITE(IUABA,800) '** DEFINITION DES ELEMENTS'
  658.       WRITE(IUABA,800) '****'
  659.       DO i=1,NB_EF
  660.         j=IN_EF*(i-1)
  661.         MELEME=MLISEF.LECT(j+1)
  662.         i_z   =MLISEF.LECT(j+2)
  663.         NumEF =MLISEF.LECT(j+3)
  664.         CHA16z=MCHAEF.LCHA16(i)
  665.         WRITE(IUABA,830) NomAba(i_z)(1:LONG(NomAba(i_z))),
  666.      &                   CHA16z(1:LONG(CHA16z))
  667. C*I   WRITE(IOIMP,501) 'Orientation selon Abq ',i
  668. C Orientation des elements du maillage selon Abaqus :
  669.         SEGACT,MELEME*MOD
  670.         nbnn=NUM(/1)
  671.         nbel=NUM(/2)
  672.         IELE=ITYPEL
  673. C Recuperation des fonctions de forme et derivees associees de
  674. C l'element fini massif de type IELE
  675.         CALL RESHPT(1,nbnn,IELE,IELE,0,ISPT,IRETOU)
  676.         IF (IRETOU.NE.1) GOTO 60
  677.         MINTE=ISPT
  678.         SEGACT,MINTE
  679.         nbno=nbnn
  680.         SEGINI,MWRK
  681.         DO iel=1,nbel
  682. C  Recuperation des coordonnees des noeuds de l'element
  683.           CALL DOXE(XCOOR,IDIM,nbnn,NUM,iel,XEL)
  684. C  Calcul du jacobien au centre de gravite de l'element
  685.           D11=0.
  686.           D21=0.
  687.           D12=0.
  688.           D22=0.
  689.           IF (IDIM.EQ.3) THEN
  690.             D31=0.
  691.             D32=0.
  692.             D13=0.
  693.             D23=0.
  694.             D33=0.
  695.             DO j=1,nbnn
  696.               D11=D11+SHPTOT(2,j,1)*XEL(1,j)
  697.               D21=D21+SHPTOT(3,j,1)*XEL(1,j)
  698.               D31=D31+SHPTOT(4,j,1)*XEL(1,j)
  699.               D12=D12+SHPTOT(2,j,1)*XEL(2,j)
  700.               D22=D22+SHPTOT(3,j,1)*XEL(2,j)
  701.               D32=D32+SHPTOT(4,j,1)*XEL(2,j)
  702.               D13=D13+SHPTOT(2,j,1)*XEL(3,j)
  703.               D23=D23+SHPTOT(3,j,1)*XEL(3,j)
  704.               D33=D33+SHPTOT(4,j,1)*XEL(3,j)
  705.             ENDDO
  706.             DInv11=D22*D33-D23*D32
  707.             DInv12=D32*D13-D12*D33
  708.             DInv13=D12*D23-D22*D13
  709.             DJAC=D11*DInv11+D21*DInv12+D31*DInv13
  710.           ELSE IF (IDIM.EQ.2) THEN
  711.             DO j=1,nbnn
  712.               D11=D11+SHPTOT(2,j,1)*XEL(1,j)
  713.               D21=D21+SHPTOT(3,j,1)*XEL(1,j)
  714.               D12=D12+SHPTOT(2,j,1)*XEL(2,j)
  715.               D22=D22+SHPTOT(3,j,1)*XEL(2,j)
  716.             ENDDO
  717.             DJAC=D11*D22-D21*D12
  718. C*        ELSE IF (IDIM.EQ.1) THEN
  719.           ELSE
  720.             DJAC=XEL(1,nbnn)-XEL(1,1)
  721.           ENDIF
  722. C  Test si le jacobien est nul (pas bon)
  723.           IF (ABS(DJAC).LE.0.) THEN
  724.             CALL ERREUR(664)
  725.             WRITE(IUABA,801) 'Element incorrect',NumEF+j
  726.           ENDIF
  727. C  Si le jacobien est negatif, on permute l'ordre des noeuds
  728.           IF (DJAC.LT.0.) THEN
  729.             DO k=1,nbno
  730.               NOEELT(k)=NUM(lInver(k,i_z),iel)
  731.             ENDDO
  732.             DO k=1,nbno
  733.               NUM(k,iel)=NOEELT(k)
  734.             ENDDO
  735.           ENDIF
  736.         ENDDO
  737.         SEGSUP,MWRK
  738.         SEGDES,MINTE
  739.  60     CONTINUE
  740.         IF (IERR.NE.0) THEN
  741.           WRITE(IOIMP,510) 'ORIENTATION - Poursuite ecriture'
  742.           WRITE(IUABA,800) '!! ERREUR ORIE - Verifier le maillage'
  743.         ENDIF
  744. C*I   WRITE(IOIMP,501) 'Ecriture des elements type '//NomAba(i_z)
  745.         DO k=1,nbel
  746.           NumEF=NumEF+1
  747.           WRITE(IUABA,831) NumEF,(NUM(lOrdre(l,i_z),k),l=1,nbno)
  748.         ENDDO
  749.         SEGDES,MELEME
  750.       ENDDO
  751.       WRITE(IUABA,FMT='(A4)') '****'
  752.       WRITE(IOIMP,501) 'Nb. type d elements =',NB_EF
  753.       WRITE(IOIMP,501) 'Nombre d elements   =',NB_ELT
  754. C Ecriture des groupes d elements
  755.       WRITE(IOIMP,502) 'Ecriture des groupes d elements'
  756.       IF (NB_GEL.GT.0) THEN
  757.         WRITE(IUABA,800) '** DEFINITION DES GROUPES D ELEMENTS'
  758.         WRITE(IUABA,800) '****'
  759. C Ecriture des groupes d elements (un seul type)
  760.         k=0
  761.         DO i=1,NBMAIL
  762.           IF (I_OBJ(i).EQ.3) THEN
  763.             WRITE(IUABA,840) C_OBJ(i)(1:LONG(C_OBJ(i)))
  764.             MLENTI=L_OBJ(i)
  765.             SEGACT,MLENTI
  766.             WRITE(IUABA,841) (LECT(j),j=1,LECT(/1))
  767.             SEGDES,MLENTI
  768.             k=k+1
  769.           ENDIF
  770.         ENDDO
  771. C*    write(ioimp,501) 'Nb. groupe d elements un seul EF',k
  772.         IF (k.NE.0) WRITE(IUABA,800) '****'
  773.         k=0
  774.         DO i=1,NBMAIL
  775.           IF (I_OBJ(i).EQ.2) THEN
  776.             CHA16z=MCHAEF.LCHA16(-L_OBJ(i))
  777.             IF (C_OBJ(i).NE.CHA16z) THEN
  778.               WRITE(IUABA,840) C_OBJ(i)(1:LONG(C_OBJ(i)))
  779.               WRITE(IUABA,800) '  '//CHA16z(1:LONG(CHA16z))
  780.               k=k+1
  781.             ENDIF
  782.           ENDIF
  783.         ENDDO
  784. C*    write(ioimp,501) 'Nb. groupe d elements def elt =',k
  785.         IF (k.NE.0) WRITE(IUABA,800) '****'
  786. C Ecriture des groupes d elements complexes
  787.         k=0
  788.         DO i=1,NBMAIL
  789.           IF (I_OBJ(i).EQ.4) THEN
  790.             WRITE(IUABA,840) C_OBJ(i)(1:LONG(C_OBJ(i)))
  791.             MLENTI=L_OBJ(i)
  792.             WRITE(IUABA,842) (C_OBJ(LECT(j))(1:LONG(C_OBJ(LECT(j)))),
  793.      &                        j=1,LECT(/1))
  794.             k=k+1
  795.           ENDIF
  796.         ENDDO
  797. C*    write(ioimp,501) 'Nb. groupe d elements complexe =',k
  798.         IF (k.NE.0) WRITE(IUABA,800) '****'
  799.       ENDIF
  800.       WRITE(IOIMP,501) 'Nombre de groupe d elements =',NB_GEL
  801.  
  802. C===
  803. C 4 - Sortie du sous-programme (menage...)
  804. C===
  805.  902  CONTINUE
  806.       WRITE(IOIMP,502) 'Fermeture du fichier au format Abaqus(R)'
  807.       IOS=1
  808.       CLOSE(UNIT=IUABA,ERR=901)
  809.       IOS=0
  810.  901  CONTINUE
  811.       DO i=1,NBMAIL
  812.         MELEME=I_MAI(i)
  813.         IF (MELEME.GT.0) SEGDES,MELEME
  814.         MLENTI=L_OBJ(i)
  815.         IF (MLENTI.GT.0) SEGSUP,MLENTI
  816.       ENDDO
  817.       SEGSUP,IMAIL
  818.  900  CONTINUE
  819.       MELEME=MAIREF
  820.       SEGACT,MELEME
  821.       IF (NB_OBJ.NE.0) THEN
  822.         DO i=1,NB_OBJ
  823.           IPT1=LISOUS(i)
  824.           SEGDES,IPT1
  825.         ENDDO
  826.       ENDIF
  827.       SEGDES,MELEME
  828.       SEGSUP,MLISEF,MCHAEF
  829. C Traitement des erreurs d ouverture ou de fermeture du fichier
  830.       IF (IOS.NE.0) THEN
  831.         l=LONG(FICABA)
  832.         MOTERR(1:l)=FICABA(1:l)
  833.         INTERR(1)=IOS
  834.         CALL ERREUR(424)
  835.       ENDIF
  836.       WRITE(IOIMP,*)
  837.  
  838. C=====
  839. C 5 - Formats Fortran
  840. C=====
  841. C Formats d impression de messages
  842.  500  FORMAT('SORABA : ',A)
  843.  501  FORMAT('         ',A,I8)
  844.  502  FORMAT('         ',A)
  845.  510  FORMAT('SORABA - ERREUR : ',A)
  846. C* 511  FORMAT('SORABA - ERREUR : ',A,' ',I4,' non defini')
  847. C* 512  FORMAT('SORABA - ERREUR : ',A,' ',I4,' mal defini')
  848. C* 513  FORMAT('SORABA - ERREUR : Lecture impossible ',A,' ',I4)
  849. C* 520  FORMAT('SORABA - ATTENTION : ',A)
  850. C* 521  FORMAT('SORABA - ATTENTION : ',A,' ',I4,' non defini')
  851. C* 522  FORMAT('SORABA - ATTENTION : ',A,' ',I4,' mal defini')
  852. C* 523  FORMAT('SORABA - ATTENTION : ',A,' ',A,' ',I4)
  853. C Formats d ecriture pour le fichier de sortie Abaqus(R)
  854.  800  FORMAT(A)
  855.  801  FORMAT(A,' ',I8)
  856.  810  FORMAT(I8,',  ',SP,E14.8,', ',E14.8,', ',E14.8,S)
  857.  811  FORMAT(I8,',  ',SP,E14.8,', ',E14.8,S)
  858.  812  FORMAT(I8,',  ',SP,E14.8,S)
  859.  820  FORMAT('*NSET, NSET=',A)
  860.  821  FORMAT(I8)
  861.  822  FORMAT(10(I8,','))
  862.  830  FORMAT('*ELEMENT, TYPE=',A,', ELSET=',A)
  863.  831  FORMAT(I8,', ',19(I8,','),I8)
  864.  840  FORMAT('*ELSET, ELSET=',A)
  865.  841  FORMAT(16(I8,','))
  866.  842  FORMAT(1X,16(A10,','))
  867.  
  868.       RETURN
  869.       END
  870.  
  871.  
  872.  

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