Sources Esope | Cast3M

fermel
C FERMEL    SOURCE    CB215821  19/08/20    21:17:43     10287          
C FERMEL    SOURCE    KK2000    98/12/22    21:15:01     3392
      SUBROUTINE FERMEL(MAILLA,IDECAL,NUMMAT,IEQUIV,IPTMIN)
 
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C  But : Sortie vers FER (ASCII) d'un maillage
C        (MELEME) élémentaire
C
C  Paramètres : MAILLA - pointeur vers le MELEME (entrée)
C               IDECAL - décalage des numéros d'éléments (entrée & sortie)
C               NUMMAT - numéro du matériau du maillage (entrée)
C#MC 03/12/98
C#   NUMMAT n'est plus utilise, il est dans la plupart des cas redondant avec
C#   le type de l'element. On prefere sortir le numero de la couleur (+1 pour
C#   ne pas commencer a 0)
C
C               IEQUIV - segment décrivant la conversion des numéros des noeuds
C               IPTMIN - numéro du premier noeud dans IEQUIV
C
C  Auteur     : Michel Bulik
C  Adaptation : Gregory Turbelin
C                     Novembre 2002
C
C  Appelé par : SORFER
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
 
 
-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC SMELEME
 
C ... Dans cette subroutine je ne touche pas à IEQUIV, on
C     s'en occupe dans LIRAVS ...
      SEGMENT IEQUIV
         INTEGER LEQUIV(IECART)
      END SEGMENT
 
C ... Tableaux de conversion de connectivités (IC&lt;nom_élément>) ...
      DIMENSION ICPOI1( 1)
      DIMENSION ICSEG2( 2)
      DIMENSION ICSEG3( 3)
      DIMENSION ICTRI3( 3)
      DIMENSION ICTRI6( 6)
      DIMENSION ICTRI62( 6)
      DIMENSION ICQUA4( 4)
      DIMENSION ICQUA8( 8)
      DIMENSION ICCUB8( 8)
      DIMENSION ICCU20(20)
      DIMENSION ICPRI6( 6)
      DIMENSION ICPR15(15)
      DIMENSION ICTET4( 4)
      DIMENSION ICTE10(10)
      DIMENSION ICPYR5( 5)
      DIMENSION ICPY13(13)
 
      DATA ICPOI1 / 1/
      DATA ICSEG2 / 1, 2/
      DATA ICSEG3 / 1, 2, 3/
      DATA ICTRI3 / 1, 2, 3/
      DATA ICTRI6 / 1, 2, 3, 4, 5, 6/
      DATA ICQUA4 / 1, 2, 3, 4/
      DATA ICQUA8 / 1, 2, 3, 4, 5, 6, 7, 8/
      DATA ICCUB8 / 1, 2, 3, 4, 5, 6, 7, 8/
      DATA ICCU20 / 1, 3, 5, 7,13,15,17,19, 2, 4,
     &              6, 8,14,16,18,20, 9,10,11,12/
      DATA ICPRI6 / 1, 2, 3, 4, 5, 6/
      DATA ICPR15 / 1, 3, 5,10,12,14, 2, 4, 6,11,
     &             13,15, 8, 7, 9/
      DATA ICTET4 / 1, 2, 3, 4/
      DATA ICTE10 / 1, 5, 7, 9, 2, 3, 4, 6, 8,10/
      DATA ICPYR5 / 5, 1, 2, 3, 4/
      DATA ICPY13 /13, 1, 3, 5, 7, 9,10,11,12, 2,
     &              4, 6, 8/
 
      MELEME=MAILLA
      SEGACT MELEME
      NBELEM=NUM(/2)
      NBNN=NUM(/1)
      IF(NBELEM.EQ.0) RETURN
 
      IF(ITYPEL.EQ.1) THEN
         DO 3030 J=1,NBELEM
            WRITE(IOPER,5001) IDECAL+J,ICOLOR(J)+1,ICOLOR(J)+1,
     &                      LEQUIV(NUM(1,J)-IPTMIN+1)
 3030    CONTINUE
      ELSE IF(ITYPEL.EQ.2) THEN
         DO 3040 J=1,NBELEM
            WRITE(IOPER,5002) IDECAL+J,ICOLOR(J)+1,ICOLOR(J)+1,
     &                     (LEQUIV(NUM(ICSEG2(K),J)-IPTMIN+1),K=1,NBNN)
 3040    CONTINUE
      ELSE IF (ITYPEL.EQ.3) THEN
         DO 3050 J=1,NBELEM
            WRITE(IOPER,5003) IDECAL+J,ICOLOR(J)+1,ICOLOR(J)+1,
     &                     (LEQUIV(NUM(ICSEG3(K),J)-IPTMIN+1),K=1,NBNN)
 3050    CONTINUE
 
      ELSE IF (ITYPEL.EQ.4) THEN
         DO 3060 J=1,NBELEM
            IF(IDIM.EQ.2) THEN
            WRITE(IOPER,5004) IDECAL+J,ICOLOR(J)+1,ICOLOR(J)+1,
     &                     (LEQUIV(NUM(ICTRI3(K),J)-IPTMIN+1),K=1,NBNN)
            ELSE
            WRITE(IOPER,5304) IDECAL+J,ICOLOR(J)+1,ICOLOR(J)+1,
     &                     (LEQUIV(NUM(ICTRI3(K),J)-IPTMIN+1),K=1,NBNN)
           ENDIF
 3060    CONTINUE
      ELSE IF (ITYPEL.EQ.6) THEN
         DO 3070 J=1,NBELEM
            IF(IDIM.EQ.2) THEN
            WRITE(IOPER,5006) IDECAL+J,ICOLOR(J)+1,ICOLOR(J)+1,
     &                     (LEQUIV(NUM(ICTRI6(K),J)-IPTMIN+1),K=1,NBNN)
            ELSE
            WRITE(IOPER,5306) IDECAL+J,ICOLOR(J)+1,ICOLOR(J)+1,
     &                     (LEQUIV(NUM(ICTRI6(K),J)-IPTMIN+1),K=1,NBNN)
           ENDIF
 3070    CONTINUE
      ELSE IF (ITYPEL.EQ.8) THEN
         DO 3080 J=1,NBELEM
           IF(IDIM.EQ.2) THEN
            WRITE(IOPER,5008) IDECAL+J,ICOLOR(J)+1,ICOLOR(J)+1,
     &                     (LEQUIV(NUM(ICQUA4(K),J)-IPTMIN+1),K=1,NBNN)
            ELSE
             WRITE(IOPER,5308) IDECAL+J,ICOLOR(J)+1,ICOLOR(J)+1,
     &                     (LEQUIV(NUM(ICQUA4(K),J)-IPTMIN+1),K=1,NBNN)
            ENDIF
 3080    CONTINUE
      ELSE IF (ITYPEL.EQ.10) THEN
         DO 3090 J=1,NBELEM
            IF(IDIM.EQ.2) THEN
            WRITE(IOPER,5010) IDECAL+J,ICOLOR(J)+1,ICOLOR(J)+1,
     &                     (LEQUIV(NUM(ICQUA8(K),J)-IPTMIN+1),K=1,NBNN)
            ELSE
            WRITE(IOPER,5310) IDECAL+J,ICOLOR(J)+1,ICOLOR(J)+1,
     &                     (LEQUIV(NUM(ICQUA8(K),J)-IPTMIN+1),K=1,NBNN)
            ENDIF
3090    CONTINUE
      ELSE IF (ITYPEL.EQ.14) THEN
         DO 3100 J=1,NBELEM
            WRITE(IOPER,5014) IDECAL+J,ICOLOR(J)+1,ICOLOR(J)+1,
     &                     (LEQUIV(NUM(ICCUB8(K),J)-IPTMIN+1),K=1,NBNN)
 3100    CONTINUE
       ELSE IF (ITYPEL.EQ.15) THEN
           GOTO 9997
c         DO 3110 J=1,NBELEM
c            WRITE(IOPER,5015) IDECAL+J,ICOLOR(J)+1,ICOLOR(J)+1,
c     &                     (LEQUIV(NUM(ICCU20(K),J)-IPTMIN+1),K=1,NBNN)
c 3110    CONTINUE
 
      ELSE IF (ITYPEL.EQ.16) THEN
          GOTO 9997
c         DO 3120 J=1,NBELEM
c            WRITE(IOPER,5016) IDECAL+J,ICOLOR(J)+1,ICOLOR(J)+1,
c     &                     (LEQUIV(NUM(ICPRI6(K),J)-IPTMIN+1),K=1,NBNN)
c 3120    CONTINUE
      ELSE IF (ITYPEL.EQ.17) THEN
          GOTO 9997
c         DO 3130 J=1,NBELEM
c            WRITE(IOPER,5017) IDECAL+J,ICOLOR(J)+1,ICOLOR(J)+1,
c     &                     (LEQUIV(NUM(ICPR15(K),J)-IPTMIN+1),K=1,NBNN)
c 3130    CONTINUE
      ELSE IF (ITYPEL.EQ.23) THEN
          GOTO 9997
c         DO 3140 J=1,NBELEM
c            WRITE(IOPER,5023) IDECAL+J,ICOLOR(J)+1,ICOLOR(J)+1,
c     &                     (LEQUIV(NUM(ICTET4(K),J)-IPTMIN+1),K=1,NBNN)
c 3140    CONTINUE
      ELSE IF (ITYPEL.EQ.24) THEN
          GOTO 9997
c         DO 3150 J=1,NBELEM
c            WRITE(IOPER,5024) IDECAL+J,ICOLOR(J)+1,ICOLOR(J)+1,
c     &                     (LEQUIV(NUM(ICTE10(K),J)-IPTMIN+1),K=1,NBNN)
c 3150    CONTINUE
      ELSE IF (ITYPEL.EQ.25) THEN
          GOTO 9997
c         DO 3160 J=1,NBELEM
c            WRITE(IOPER,5025) IDECAL+J,ICOLOR(J)+1,ICOLOR(J)+1,
c     &                     (LEQUIV(NUM(ICPYR5(K),J)-IPTMIN+1),K=1,NBNN)
c 3160    CONTINUE
      ELSE IF (ITYPEL.EQ.26) THEN
          GOTO 9997
c         DO 3170 J=1,NBELEM
c            WRITE(IOPER,5026) IDECAL+J,ICOLOR(J)+1,ICOLOR(J)+1,
c     &                     (LEQUIV(NUM(ICPY13(K),J)-IPTMIN+1),K=1,NBNN)
c 3170    CONTINUE
      ELSE
         MOTERR(1:4)=NOMS(ITYPEL)
         CALL ERREUR(701)
      ENDIF
C ... Dans le cas d'un ITYPEL inconnu j'incrémente quand même IDECAL,
C     ceci laissera un "trou" dans le fichier AVS et permettra (je
C     l'espère) trouver l'erreur plus facilement ...
      IDECAL=IDECAL+NBELEM
 
      RETURN
C ... Format 50?? correspond à 5000+ITYPEL ...
C ... Format 53?? correspond à la verion 3D ...
 
 5001 FORMAT(I6,'  1','  99',I3,I3,1I6)
 5002 FORMAT(I6,'  2','  22',I3,I3,2I6)
 5003 FORMAT(I6,'  3','  23',I3,I3,3I6)
 5004 FORMAT(I6,'  3','  23',I3,I3,3I6)
 5304 FORMAT(I6,'  3','  43',I3,I3,3I6)
 5006 FORMAT(I6,'  6','  26',I3,I3,6I6)
 5306 FORMAT(I6,'  6','  46',I3,I3,6I6)
 5008 FORMAT(I6,'  4','  24',I3,I3,4I6)
 5308 FORMAT(I6,'  4','  44',I3,I3,4I6)
 5010 FORMAT(I6,'  8','  28',I3,I3,8I6)
 5310 FORMAT(I6,'  8','  48',I3,I3,8I6)
 5014 FORMAT(I6,'  8','  38',I3,I3,8I6)
 5015 FORMAT(I6,'  20','  320',I3,I3,20I6)
 5023 FORMAT(I6,'  4','  34',I3,I3,4I6)
 5024 FORMAT(I6,'  10','  310',I3,I3,10I6)
 
 5016 FORMAT(I6,'  6',' prism',I3,I3,6I6)
 5017 FORMAT(I6,'  15',' prism',I3,I3,15I6)
 5025 FORMAT(I6,'  5','   pyr',I3,I3,5I6)
 5026 FORMAT(I6,'  13','   pyr',I3,I3,13I6)
 
 
*
* Error handling
*
 9997 CONTINUE
      WRITE(IOIMP,*) 'Le support géométrique contient'
      WRITE(IOIMP,*) 'des types d''éléments non testés'
C     WRITE(IOIMP,*) 'Les types déléments supportés sont:'
      GOTO 9999
 
 9999 CONTINUE
      WRITE(IOIMP,*) 'An error was detected in subroutine fermel'
C Erreur détectée au cours du processus
      CALL ERREUR(223)
      RETURN
*
* End of subroutine  FERMEL
*
      END