Sources Esope | Cast3M

kkdom2
C KKDOM2    SOURCE    CHAT      05/01/13    00:56:44     5004
C KKDOM     SOURCE    MAGN      02/10/07    21:15:19     4439
      SUBROUTINE KKDOM2(MELEME,TOLER,NOMDOM,MTABI,MTABD,INEFMD)
C************************************************************************
C
C  OBJET   : Cree une table de soustype DOMAINE
C            Appele par KDOM
C
C************************************************************************
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
      CHARACTER*8 NOMDOM,NOMC
      CHARACTER*8 NOM,TYPE,TYPI
      PARAMETER (NMEL=8)
      DIMENSION SGA(NMEL),SEPS(NMEL),SEPSD(NMEL)
C***
 
-INC PPARAM
-INC CCOPTIO
-INC SMELEME
      POINTEUR MELEMS.MELEME,MELEMC.MELEME,MELEF1.MELEME,MELEMP.MELEME
      POINTEUR MFF2.MELEME
-INC SMLENTI
      DATA SGA/1.D0,1.D0,1.D0,1.D0,1.D0,1.D0,1.D0,1.D0/
      DATA SEPS/0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0,0.D0/
      DATA SEPSD/8*0.D0/
C***
 
C On verifie que si la directive INCL est présente les SPG
C des points sommets sont bien inclus
 
      MELEP0=0
C     write(6,*)' DEBUT KKDOM ========================'
      IF(MTABI.NE.0)THEN
         TYPI='MAILLAGE'
         CALL ACMO(MTABI,'SOMMET',TYPI,MSI)
         CALL KRIPAD(MSI,MLENTI)
         CALL VERPAD(MLENTI,MELEME,IRET)
         IF(IRET.NE.0)THEN
            WRITE(6,*)' Opérateur DOMA '
            WRITE(6,*)' Le maillage n''est pas contenu dans celui de'
     &           ,' la table donnée pour la directive INCL '
            RETURN
         ENDIF
         SEGSUP MLENTI
      ENDIF
 
C???   call CQF2LN(MELEME,MLINE)
      CALL KQCEST(MELEME,IKR)
 
      IF(IKR.EQ.1341)IKR=1
      IF(IKR.EQ.13)IKR=1
 
      IF(IKR.EQ.2)THEN
C au depart des LINEs -> LINE
C     write(6,*)'au depart des LINEs -> LINE'
 
         CALL ECROBJ('MAILLAGE',MELEME)
         CALL CHANQU
         CALL C20227
         IF (IERR.NE.0) RETURN
         CALL LIROBJ('MAILLAGE',MELEME,1,IRET)
         MAIL=MELEME
         CALL CQF2LN(MELEME,MLINE)
C        write(6,*)' AVT TQ2CF'
         NOMC=' '
         CALL TQ2CF(MAIL,MELEMQ,MELEMC,
     &   MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR)
         MELEME=MLINE
      ELSEIF(IKR.EQ.1.AND.INEFMD.EQ.1)THEN
C au depart des QUAFs -> LINE
C     write(6,*)'au depart des QUAFs -> LINE '
 
         MAIL=MELEME
C        write(6,*)' KKDOM QUAFs -> LINE'
         NOMC=' '
         CALL TQ2CF(MAIL,MELEMQ,MELEMC,
     &   MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR)
         CALL CQF2LN(MELEME,MLINE)
         MELEME=MLINE
C?       MELEME=MAIL
      ENDIF
 
C        write(6,*)' APR MTABI=',mtabi
      CALL CRTABL(MTABD)
      CALL ECMM(MTABD,'SOUSTYPE','DOMAINE')
      CALL ECME(MTABD,'PRECONDI',1)
C     write(6,*)' QUAF MELEMQ=',MELEMQ
C?    call ecrobj('MAILLAGE',MELEMQ)
C?    call prlist
      CALL ECMO(MTABD,'QUAF','MAILLAGE',MELEMQ)
      IF(MTABI.NE.0) CALL ECMO(MTABD,'PERE','TABLE',MTABI)
      CALL ECMM(MTABD,'NOMDOM',NOMDOM)
      CALL ECMO(MTABD,'MAILLAGE','MAILLAGE',MELEME)
      CALL ECME(MTABD,'INEFMD',INEFMD)
 
C     write(6,*)' MELEF1,MELEMF,MELEMP,MELEMC,MELAF=',
C    &MELEF1,MELEMF,MELEMP,MELEMC,MELAF
      CALL ECMO(MTABD,'FACE','MAILLAGE',MELEF1)
      CALL ECMO(MTABD,'FACEL','MAILLAGE',MELEMF)
      CALL ECMO(MTABD,'FACEP','MAILLAGE',MELEMP)
      CALL ECMO(MTABD,'CENTRE','MAILLAGE',MELEMC)
      CALL ECMO(MTABD,'ELTFA','MAILLAGE',MELAF)
      CALL ECMO(MTABD,'FACEL2','MAILLAGE',MELEF2)
      CALL ECMO(MTABD,'MAILFACE','MAILLAGE',MFF2)
      CALL ECMF(MTABD,'TOLER',TOLER)
 
C?    CALL ECRCHA('POI1')
C?    CALL ECROBJ('MAILLAGE',MELEME)
C?    CALL ECROBJ('MAILLAGE',MAIL  )
C?    CALL PRCHAN
C?    CALL LIROBJ('MAILLAGE',MELEMS,1,IRET)
C?    IF(IRET.EQ.0)RETURN
      CALL CM2PO1(MELEME,MELEMS)
      CALL ECMO(MTABD,'SOMMET','MAILLAGE',MELEMS)
C???? IF(MELEMS.EQ.0)RETURN
 
C        write(6,*)' MTABI=',mtabi,' retour si 0 '
         IF(MTABI.NE.0)THEN
 
C         In CRTABL -> SEGINI MTBT0
         CALL CRTABL(MTBT0)
         CALL ECME(MTBT0,'PRECONDI',1)
         CALL NOMOBJ('TABLE','tabl0tmp',MTBT0)
 
         CALL ECMO(MTBT0,'QUAF','MAILLAGE',MELEMQ)
         CALL ECMO(MTBT0,'SOMMET','MAILLAGE',MELEMS)
         CALL ECMO(MTBT0,'FACE  ','MAILLAGE',MELEF1)
         CALL ECMO(MTBT0,'FACEL','MAILLAGE',MELEMF)
         CALL ECMO(MTBT0,'FACEP','MAILLAGE',MELEMP)
         CALL ECMO(MTBT0,'CENTRE','MAILLAGE',MELEMC)
         CALL ECMO(MTBT0,'ELTFA','MAILLAGE',MELAF)
         CALL ECMO(MTBT0,'FACEL2','MAILLAGE',MELEF2)
         CALL ECMO(MTBT0,'MAILFACE','MAILLAGE',MFF2)
         CALL ECMO(MTBT0,'MAILLAGE','MAILLAGE',MELEME)
 
C      write(6,*)' On vérifie l inclusion des points sommets '
C On vérifie l'inclusion des points sommets (on peut avoir créé des pts centre)
            TYPI='MAILLAGE'
            CALL ACMO(MTABI,'SOMMET',TYPI,MSI)
            CALL ACMO(MTABI,'FACE',TYPI,MFI)
            CALL ACMO(MTABI,'CENTRE',TYPI,MCI)
            CALL ECROBJ('MAILLAGE',MFI)
            CALL ECROBJ('MAILLAGE',MCI)
            CALL PRFUSE
            CALL ECROBJ('MAILLAGE',MSI)
            CALL PRFUSE
            CALL ECROBJ('MAILLAGE',MELEMS)
            CALL PRFUSE
            CALL ECROBJ('MAILLAGE',MELEF1)
            CALL PRFUSE
            CALL ECROBJ('MAILLAGE',MELEMC)
            CALL PRFUSE
            CALL ECRREE(TOLER)
            CALL PRELIM(0)
            CALL LIROBJ('MAILLAGE',MMMMM,1,IRET)
         ENDIF
C      write(6,*)' APRES verification '
 
      SEGACT MELEF1
      NBFD=MELEF1.NUM(/2)
      SEGDES MELEF1
      SEGACT MELEMC
      NELD=MELEMC.NUM(/2)
      SEGDES MELEMC
      SEGACT MELEMS
      NPTD=MELEMS.NUM(/2)
      SEGDES MELEMS
 
      CALL ECME(MTABD,'NPTD',NPTD)
      CALL ECME(MTABD,'NELD',NELD)
      CALL ECME(MTABD,'NBFD',NBFD)
 
C     write(6,*)' Appel a REFE'
      CALL ECROBJ('MAILLAGE',MELEME)
      CALL REFE
      CALL LIROBJ('LISTMOTS',ITABOG,0,IRET)
      CALL ECMO(MTABD,'OBJINCLU','LISTMOTS',ITABOG)
C     write(6,*)' FIN KKDOM ********************** '
 
      RETURN
      END