Sources Esope | Cast3M

kmacro
C KMACRO    SOURCE    BP208322  16/11/18    21:18:14     9177           
      SUBROUTINE KMACRO(MELEME,MELEMM,MTABZ)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
 
      CHARACTER*8 TYPE,TYP2
-INC CCGEOME
-INC SMELEME
      POINTEUR MELEMM.MELEME
 
      TYPE=' '
      CALL ACMO(MTABZ,'MACRO1',TYPE,MELEMM)
      IF(MELEMM.NE.0)RETURN
 
      CALL ACMF(MTABZ,'TOLER',TOLER)
      TYP2='MAILLAGE'
      CALL ACMO(MTABZ,'SOMMET',TYP2,MELEMS)
 
      ICHAN=0
      SEGACT MELEME
      NBSOUS=LISOUS(/1)
      NBREF =0
 
      IF(NBSOUS.EQ.0)THEN
      NBSOUL=1
      ELSE
      NBSOUL=NBSOUS
      ENDIF
 
      NBREF=0
      NBNN=0
      NBELEM=0
      SEGINI MELEMM
 
      DO 1 L=1,NBSOUL
      IPT1=MELEME
      IF(NBSOUL.NE.1)IPT1=LISOUS(L)
      SEGACT IPT1
      IPT2=IPT1
 
      IF(NOMS(IPT1.ITYPEL).EQ.'QUA8')THEN
      ICHAN=1
      CALL ECRCHA('QUA9')
      CALL ECROBJ('MAILLAGE',IPT1)
      CALL PRCHAN
      CALL LIROBJ('MAILLAGE',IPT2,1,IRET)
      IF(IRET.NE.1)RETURN
 
      CALL ECROBJ('MAILLAGE',IPT2)
      CALL ECROBJ('MAILLAGE',MELEMS)
      CALL PRFUSE
      CALL ECRREE(TOLER)
      CALL PRELIM(0)
      CALL LIROBJ('MAILLAGE',IPT0,1,IRET)
      IF(IRET.NE.1)RETURN
 
      ENDIF
 
      IF(NBSOUL.NE.1)THEN
      MELEMM.LISOUS(L)=IPT2
      ELSE
      MELEMM=IPT2
      ENDIF
 
 1    CONTINUE
 
      CALL ECMO(MTABZ,'MACRO1','MAILLAGE',MELEMM)
      RETURN
      END