Télécharger msomet.eso

Retour à la liste

Numérotation des lignes :

  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