Télécharger kmacro.eso

Retour à la liste

Numérotation des lignes :

  1. C KMACRO SOURCE BP208322 16/11/18 21:18:14 9177
  2. SUBROUTINE KMACRO(MELEME,MELEMM,MTABZ)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5.  
  6. CHARACTER*8 TYPE,TYP2
  7. -INC CCGEOME
  8. -INC SMELEME
  9. POINTEUR MELEMM.MELEME
  10.  
  11. TYPE=' '
  12. CALL ACMO(MTABZ,'MACRO1',TYPE,MELEMM)
  13. IF(MELEMM.NE.0)RETURN
  14.  
  15. CALL ACMF(MTABZ,'TOLER',TOLER)
  16. TYP2='MAILLAGE'
  17. CALL ACMO(MTABZ,'SOMMET',TYP2,MELEMS)
  18.  
  19. ICHAN=0
  20. SEGACT MELEME
  21. NBSOUS=LISOUS(/1)
  22. NBREF =0
  23.  
  24. IF(NBSOUS.EQ.0)THEN
  25. NBSOUL=1
  26. ELSE
  27. NBSOUL=NBSOUS
  28. ENDIF
  29.  
  30. NBREF=0
  31. NBNN=0
  32. NBELEM=0
  33. SEGINI MELEMM
  34.  
  35. DO 1 L=1,NBSOUL
  36. IPT1=MELEME
  37. IF(NBSOUL.NE.1)IPT1=LISOUS(L)
  38. SEGACT IPT1
  39. IPT2=IPT1
  40.  
  41. IF(NOMS(IPT1.ITYPEL).EQ.'QUA8')THEN
  42. ICHAN=1
  43. CALL ECRCHA('QUA9')
  44. CALL ECROBJ('MAILLAGE',IPT1)
  45. CALL PRCHAN
  46. CALL LIROBJ('MAILLAGE',IPT2,1,IRET)
  47. IF(IRET.NE.1)RETURN
  48.  
  49. CALL ECROBJ('MAILLAGE',IPT2)
  50. CALL ECROBJ('MAILLAGE',MELEMS)
  51. CALL PRFUSE
  52. CALL ECRREE(TOLER)
  53. CALL PRELIM(0)
  54. CALL LIROBJ('MAILLAGE',IPT0,1,IRET)
  55. IF(IRET.NE.1)RETURN
  56.  
  57. ENDIF
  58.  
  59. IF(NBSOUL.NE.1)THEN
  60. MELEMM.LISOUS(L)=IPT2
  61. ELSE
  62. MELEMM=IPT2
  63. ENDIF
  64.  
  65. 1 CONTINUE
  66.  
  67. CALL ECMO(MTABZ,'MACRO1','MAILLAGE',MELEMM)
  68. RETURN
  69. END
  70.  
  71.  
  72.  
  73.  
  74.  
  75.  
  76.  
  77.  
  78.  

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