Télécharger la plaquette Cast3M


fr en

Télécharger msomet.eso

Retour à la liste

Numérotation des lignes : 

msomet

  1. C MSOMET    SOURCE    BP208322  16/11/18    21:19:30     9177           
  2.       SUBROUTINE MSOMET(MELEME,MELEMM,MELEMS,TYPE)
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8 (A-H,O-Z)
  5.  
  6.       CHARACTER*8 TYPE
  7.       PARAMETER (NBTYP=7)
  8.       DIMENSION LISTN(4,NBTYP),ITAB(8,7)
  9.  
  10. -INC PPARAM
  11. -INC CCOPTIO
  12. -INC CCGEOME
  13. -INC SMELEME
  14.       POINTEUR MELEMM.MELEME
  15.       DATA LISTN/
  16. C     seg3      qua9       tri7
  17.      &3,2,3,2,  11,8,8,4,  7,4,6,3,
  18. C     seg2      qua4       tri3
  19. C     cu27        pr21        te15        py19
  20.      &33,14,20,8, 34,16,18,6, 35,23,10,4, 36,25,13,5/
  21. C     cub8        pri6        tet4        pyr5
  22.       DATA ITAB/
  23.      & 1,3,6*0,  1,3,5,7,4*0,  1,3,5,5*0,
  24.      & 1,3,5,7,13,15,17,19,  1,3,5,10,12,14,2*0,
  25.      & 1,3,5,10,4*0,  1,3,5,7,13,3*0 /
  26.  
  27.       TYPE=' '
  28.       SEGACT MELEME
  29.       NBSOUS=MAX(1,LISOUS(/1))
  30.       NBREF=0
  31.       NBELEM=0
  32.       NBNN=0
  33.       SEGINI MELEMM
  34.  
  35.       DO 1 L=1,MAX(1,LISOUS(/1))
  36.       IPT1=MELEME
  37.       IF(LISOUS(/1).NE.0)IPT1=LISOUS(L)
  38.       SEGACT IPT1
  39.       DO 2 M=1,NBTYP
  40. C     write(6,*)' MSOMET : IPT1.ITYPEL=',IPT1.ITYPEL
  41.       IF(IPT1.ITYPEL.EQ.LISTN(1,M))GO TO 21
  42.  2    CONTINUE
  43. C     write(6,*)' MSOMET :echec 1 '
  44.       RETURN
  45.  21   CONTINUE
  46.       NBSOUS=0
  47.       NBELEM=IPT1.NUM(/2)
  48.       NBNN=LISTN(4,M)
  49.       SEGINI IPT2
  50.       IPT2.ITYPEL=LISTN(2,M)
  51.       MELEMM.LISOUS(L)=IPT2
  52.       NP=LISTN(3,M)
  53. C     write(6,*)'NBNN NBELEM=',NBNN,NBELEM,' M=',M
  54.  
  55.  
  56.  
  57.       IF(M.LE.7)THEN
  58.       DO 101 K=1,NBELEM
  59.       DO 101 I=1,NBNN
  60.       I1=ITAB(I,M)
  61.       IPT2.NUM(I,K)=IPT1.NUM(I1,K)
  62.  101  CONTINUE
  63.  
  64.       ELSE
  65.       RETURN
  66.       ENDIF
  67.  1    CONTINUE
  68.       IPT3=MELEMM
  69.       IF(MELEMM.LISOUS(/1).EQ.1)THEN
  70.       MELEMM=MELEMM.LISOUS(1)
  71.       SEGSUP IPT3
  72.       ENDIF
  73.       MELEMS=MELEMM
  74.       ITY=1
  75.       CALL CHANGE(MELEMS,ITY)
  76.       IF (IERR.NE.0) RETURN
  77.       TYPE='MAILLAGE'
  78.  
  79.       RETURN
  80.       END
  81.  
  82.  
  83.  
  84.  
  85.  
  86.  
  87.  
  88.  
  89.  
  90.  
  91.  
  92.  
  93.  

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