Télécharger kkdom.eso

Retour à la liste

kkdom
C KKDOM     SOURCE    PV        22/04/19    16:18:05     11344          
      SUBROUTINE KKDOM(MELEME,MACRO,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)
-INC CCNOYAU
      CHARACTER*8 NOMC
      CHARACTER*(*) NOMDOM
      CHARACTER*8 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)
C     write(6,*)' IKR=',IKR,' MACRO=',MACRO,' INEFMD=',INEFMD
 
C?    IF(IKR.EQ.13.AND.MACRO.NE.0)IKR=1
C?    IF(IKR.EQ.134.AND.MACRO.NE.0)IKR=1
      IF(IKR.EQ.13.AND.MACRO.NE.0)IKR=4
      IF(IKR.EQ.134.AND.MACRO.NE.0)IKR=4
      IF(IKR.EQ.34.AND.MACRO.NE.0)IKR=3
      IF(IKR.EQ.1341.AND.MACRO.EQ.0)IKR=1
      IF(IKR.EQ.13.AND.MACRO.EQ.0)IKR=1
 
      IF(IKR.EQ.1341.AND.MACRO.NE.0)THEN
C au depart des SEG3 -> LINE -> MACRO
C     write(6,*)'au depart des SEG3 -> LINE -> MACRO'
 
         MACRO =MELEME
         MACRO1=MELEME
         CALL ECROBJ('MAILLAGE',MELEME)
         CALL CQ2L
         CALL LIROBJ('MAILLAGE',MLINE,1,IRET)
         MELEME=MLINE
         MAIL=MLINE
         NOMC=' '
         CALL TQ2CF(MAIL,MELEMQ,MELEMC,
     &   MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR)
         IQUAD=0
 
      ELSEIF(IKR.EQ.1.AND.MACRO.EQ.0.AND.INEFMD.EQ.4)THEN
C au depart des QUAFs -> LINB
C     write(6,*)'au depart des QUAFs -> LINB'
 
         MAIL=MELEME
         CALL ECROBJ('MAILLAGE',MELEME)
         CALL CLINB
         IF (IERR.NE.0) RETURN
         CALL LIROBJ('MAILLAGE',MLINB,1,IRET)
C        write(6,*)' AVT TQ2CF'
         NOMC=' '
         CALL TQ2CF(MAIL,MELEMQ,MELEMC,
     &   MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR)
         MELEME=MLINB
         IQUAD=0
 
      ELSEIF(IKR.NE.2.AND.MACRO.EQ.0.AND.INEFMD.NE.1)THEN
C au depart des QUADs ou QUAF -> QUAF
C     write(6,*)'au depart des QUADs ou QUAF -> QUAF'
 
         CALL ECROBJ('MAILLAGE',MELEME)
         CALL C20227
         IF (IERR.NE.0) RETURN
         CALL LIROBJ('MAILLAGE',MELEME,1,IRET)
         MAIL=MELEME
         NOMC=' '
         CALL TQ2CF(MAIL,MELEMQ,MELEMC,
     &   MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR)
         IQUAD=1
 
      ELSEIF(IKR.EQ.2.AND.MACRO.EQ.0)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
         IQUAD=0
 
      ELSEIF((IKR.EQ.3.OR.IKR.EQ.4).AND.MACRO.NE.0)THEN
C au depart des QUADs -> MACRO
C     write(6,*)'au depart des QUADs -> MACRO '
 
         MACRO=MELEME
         CALL ECROBJ('MAILLAGE',MELEME)
         CALL CMACRO
         IF (IERR.NE.0) RETURN
         CALL LIROBJ('MAILLAGE',MACRO1,1,IRET)
         CALL ECROBJ('MAILLAGE',MACRO1)
         CALL CQ2L
         IF (IERR.NE.0) RETURN
         CALL LIROBJ('MAILLAGE',MELEME,1,IRET)
         MAIL=MELEME
         NOMC=' '
         CALL TQ2CF(MAIL,MELEMQ,MELEMC,
     &   MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR)
         IQUAD=0
 
      ELSEIF(IKR.EQ.1.AND.MACRO.NE.0)THEN
C au depart des QUAFs -> MACRO
C     write(6,*)'au depart des QUAFs -> MACRO '
 
         MAIL=MELEME
         MACRO=MELEME
         CALL CQF2MC(MELEME,MACRO1)
         IF (IERR.NE.0) RETURN
         CALL ECROBJ('MAILLAGE',MACRO1)
         CALL CQ2L
         IF (IERR.NE.0) RETURN
         CALL LIROBJ('MAILLAGE',MELEME,1,IRET)
         NOMC=' '
         CALL TQ2CF(MAIL,MELEMQ,MELEP0,
     &   MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR)
 
         CALL TQ2CF(MELEME,MQ,MELEMC,
     &   MELEF1,MELAF,MELEMP,MELEMF,MELEF2,MFF2,NOMC,IKR)
 
C?       CALL KRECTR(MELEME,MELEMC)
         IQUAD=0
 
      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
         IQUAD=0
 
      ENDIF
 
C        write(6,*)' APR MTABI=',mtabi
      CALL CRTABL(MTABD)
      CALL ECMM(MTABD,'SOUSTYPE','DOMAINE')
      CALL ECME(MTABD,'PRECONDI',0)
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)
      IF(MACRO.NE.0)THEN
         CALL ECMO(MTABD,'MACRO','MAILLAGE',MACRO)
         CALL ECMO(MTABD,'QUAF ','MAILLAGE',MACRO)
         CALL ECMO(MTABD,'MACRO1','MAILLAGE',MACRO1)
      ELSEIF(IQUAD.EQ.1)THEN
         CALL ECMO(MTABD,'QUADRATIQUE','MAILLAGE',MELEME)
         CALL ECMO(MTABD,'MAILLAGE','MAILLAGE',MELEMQ)
         MQ=MELEMQ
         MELEMQ=MELEME
         MELEME=MQ
      ENDIF
 
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)
 
      IF(MACRO.NE.0)THEN
      IF(MELEP0.NE.0)
     &CALL ECMO(MTABD,'CENTREP0','MAILLAGE',MELEP0)
C     CALL KRECTR(MELEME,MELEMC)
      CALL ECMO(MTABD,'CENTRE','MAILLAGE',MELEMC)
      COEF=0.D0
C     write(6,*)' APPEL a KMLSTB MACRO1=',MACRO1
      CALL KMLSTB(MACRO1,MELEME,MELEMC,MELSTB,MCHPOC,
     &            IRETM,SGA,SEPS,SEPSD,COEF)
C     write(6,*)' RETOUR de KMLSTB '
        IF(IRETM.EQ.1)THEN
        CALL ECMO(MTABD,'MELSTB','MAILLAGE',MELSTB)
        CALL ECMO(MTABD,'MCHPOC','CHPOINT ',MCHPOC)
        ENDIF
      ENDIF
 
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',0)
         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)
 
      IF(MACRO.NE.0)THEN
         CALL ECMO(MTBT0,'MACRO','MAILLAGE',MACRO)
         CALL ECMO(MTBT0,'MACRO1','MAILLAGE',MACRO1)
           IF(IRETM.EQ.1)THEN
           CALL ECMO(MTBT0,'MELSTB','MAILLAGE',MELSTB)
           CALL ECMO(MTBT0,'MCHPOC','CHPOINT ',MCHPOC)
           ENDIF
      ELSEIF(IQUAD.EQ.1)THEN
         CALL ECMO(MTBT0,'MELEMQ','MAILLAGE',MELEMQ)
      ENDIF
 
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,*)' FIN KKDOM ********************** '
 
      RETURN
      END
 
 
 
 
 
 
 
 
 
 
 
 
 
 

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