Télécharger kdam.eso

Retour à la liste

kdam
C KDAM      SOURCE    BP208322  16/11/18    21:18:05     9177           
      SUBROUTINE KDAM
C************************************************************************
C
C  OBJET   : Cree une table de soustype DOMAINE
C  SYNTAXE : A = KDOM OBJ1 <IMPR>
C
C                OBJ1 objet 'MAILLAGE'
C                IMPR  impressions de controle
C La table cree contient les informations suivantes:
C
C          Indice                          Objet
C    Type    Valeur                  Type     Valeur
C  MOT       SOUSTYPE              MOT       DOMAINE
C  MOT       MAILLAGE              MAILLAGE
C  MOT       SOMMET                MAILLAGE
C  MOT       CENTRE                MAILLAGE
C  MOT       FACE                  MAILLAGE
C  MOT       FACEL                 MAILLAGE
C  MOT       NPTD                  ENTIER
C  MOT       NELD                  ENTIER
C  MOT       NBFD                  ENTIER
C  MOT       OBJINCLU              LISTMOTS
C************************************************************************
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER (NMO1=4)
      CHARACTER*8 MO1(NMO1)
      CHARACTER*8 NOM,TYPEL(20),NEM,TYPE,NOMI,MTYP,TYPI
      PARAMETER (LM1=9)
      CHARACTER*8 LIST1(LM1),LIST2(LM1)
      PARAMETER (NMEL=8)
      CHARACTER*4 MOEL(NMEL)
      DIMENSION SGA(NMEL),SEPS(NMEL),SEPSD(NMEL)
C***
 
-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC SMLMOTS
      POINTEUR TABOG.MLMOTS
-INC SMELEME
      POINTEUR MELEMS.MELEME,MELEMC.MELEME,MELEF1.MELEME
      POINTEUR MELEMP.MELEME
-INC SMCOORD
-INC SMLENTI
-INC SMTABLE
      POINTEUR MTABD.MTABLE
      POINTEUR MTABI.MTABLE,MTBT0.MTABLE
      DATA MO1/'IMPR    ','INCL    ','MACRO   ','        '/
      DATA LIST1/'VOLUME  ','COTE    ','DIAMAX  ','DIAMIN  ',
     &     'NORMALE ','SURFACE ','ORIENTAT','DSOMMET ','DCENTRE '/
      DATA LIST2/'XXVOLUM ','XXCOTE  ','XXDIAME ','XXDIEMIN',
     &     'XXNORMAF','XXSURFAC','XXNORMAE','XXDIAGSI','XXVOLUM '/
      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/
      DATA MOEL/'TRI6','QUA8','SEG3','CU20','PR15','TE10','PY13','CHAH'/
C***
 
      COEF=0.D0
      KCHAHU=0
      MTABI=0
      MACRO=0
      CALL LIROBJ('MAILLAGE',MELEME,0,IRET)
      IF(IRET.EQ.0)THEN
         CALL LIROBJ('TABLE',MTABLE,1,IRET)
         IF(IRET.EQ.0)THEN
            WRITE(6,*)' On attend un objet MAILLAGE ou un objet TABLE'
            RETURN
         ENDIF
         CALL LIRCHA(NOM,1,LCHAR)
         IF(LCHAR.EQ.0)THEN
            WRITE(6,*)' On attend une CHAINE'
            RETURN
         ENDIF
         CALL OPTLI(IP,LIST1,NOM,LM1)
         IF(IP.NE.0)THEN
            NOMI=LIST2(IP)
         ELSE
            NOMI=NOM
         ENDIF
         CALL LEKTAB(MTABLE,NOMI,IPOINT)
         IF(IPOINT.EQ.0)RETURN
         TYPE=' '
C     -> In ACCTAB : SEGACT MTABLE
         CALL ACMO(MTABLE,NOMI,TYPE,IPOINT)
         SEGDES MTABLE
         CALL ECROBJ(TYPE,IPOINT)
         RETURN
      ENDIF
 
 
      CALL XDIAMM(MELEME,DIAM)
      DIAM=DIAM*0.0003D0
      CALL LIRREE(TOLER,0,IRET)
      IF(IRET.EQ.0)TOLER=DIAM
 
      CALL QUENOM(NOM)
 
      IMPR=0
 1    CONTINUE
 
 21   CONTINUE
      CALL QUETYP(MTYP,0,IRET)
      IP=0
      IF(MTYP.EQ.'MOT')THEN
         CALL LIRCHA(NOM,1,LCHAR)
         IF(NOM.EQ.'        ')GO TO 21
         CALL OPTLI(IP,MO1,NOM,NMO1)
         IF(IP.EQ.4)IP=0
      ENDIF
 
      IF(IP.EQ.1)THEN
 
         IMPR=1
         GO TO 1
 
      ELSEIF(IP.EQ.2)THEN
 
         CALL LIROBJ('TABLE',MTABI,1,IRET)
         IF(IRET.EQ.0)RETURN
         CALL LIRREE(TOLER,0,IRET)
         IF(IRET.EQ.0)TOLER=DIAM
         GO TO 1
 
      ELSEIF(IP.EQ.3)THEN
 
         MACRO=1
 11      CONTINUE
         CALL LIRMOT(MOEL,NMEL,IPE,0)
         IF(IPE.EQ.0)GO TO 1
         IF(IPE.EQ.8)THEN
 
            CALL LIRREE(XVALC,0,IRET)
            IF(IRET.EQ.1)THEN
               KCHAHU=1
               COEF=XVALC
            ENDIF
            GO TO 11
 
         ENDIF
 
         CALL LIRREE(XVAL1,1,IRET)
         IF(IRET.EQ.0)RETURN
         CALL LIRREE(XVAL2,1,IRET)
         IF(IRET.EQ.0)RETURN
         CALL LIRREE(XVAL3,1,IRET)
         IF(IRET.EQ.0)RETURN
         SGA(IPE)=XVAL1
         SEPS(IPE)=XVAL2
         SEPSD(IPE)=XVAL3
         GO TO 11
 
      ELSE
         GO TO 2
      ENDIF
 
 2    CONTINUE
 
C On verifie que si la directive INCL est présente les SPG
C des points sommets sont bien inclus
 
      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
 
      IF(MACRO.NE.0)THEN
 
         MACRO=MELEME
C         In CRTABL -> SEGINI MTBT0
         CALL CRTABL(MTBT0)
         CALL NOMOBJ('TABLE','tabl0tmp',MTBT0)
         IF(IDIM.EQ.2)THEN
 
C     write(6,*)' KCHAHU,coef=',KCHAHU,coef
            IF(KCHAHU.EQ.1)CALL CHAHUT(MACRO,COEF)
            CALL KTRSF(MACRO,MELEME,MTBT0,IRET,SGA,SEPS,SEPSD,COEF)
 
         ELSE
            CALL KTRS3(MACRO,MELEME,MTBT0,IRET,SGA,SEPS,SEPSD,COEF)
            CALL ECROBJ('MAILLAGE',MELEME)
            CALL ECRREE(TOLER)
            CALL PRELIM(0)
            CALL LIROBJ('MAILLAGE',MMMMM,1,IRET)
         ENDIF
         IF(IRET.EQ.0)RETURN
 
         IF(MTABI.NE.0)THEN
            TYPI='MAILLAGE'
            CALL ACMO(MTABI,'SOMMET',TYPI,MSI)
            CALL ECROBJ('MAILLAGE',MSI)
            CALL ECROBJ('MAILLAGE',MELEME)
            CALL PRFUSE
            CALL ECRREE(TOLER)
            CALL PRELIM(0)
            CALL LIROBJ('MAILLAGE',MMMMM,1,IRET)
         ENDIF
 
      ENDIF
 
C Fin MACRO
 
C Debut KFCE
 
      IF(MTABI.NE.0)THEN
         CALL ECRREE(TOLER)
         CALL ECROBJ('TABLE',MTABI)
         CALL ECRCHA('INCL')
      ENDIF
      CALL ECROBJ('MAILLAGE',MELEME)
      CALL ECRREE(TOLER)
 
      MELEMQ=0
      CALL KFCE(IQUAD,MELEMQ)
      CALL LIROBJ('MAILLAGE',MELAF,1,IRET)
      CALL LIROBJ('MAILLAGE',MELEMC,1,IRET)
      CALL LIROBJ('MAILLAGE',MELEMP,1,IRET)
      CALL LIROBJ('MAILLAGE',MELEMF,1,IRET)
      CALL LIROBJ('MAILLAGE',MELEF1,1,IRET)
      IF(IRET.EQ.0)RETURN
 
      CALL CRTABL(MTABD)
      CALL ECMM(MTABD,'SOUSTYPE','DOMAINE')
      IF(MTABI.NE.0) CALL ECMO(MTABD,'PERE','TABLE',MTABI)
      CALL ECMM(MTABD,'NOMDOM',NOM)
      CALL ECMO(MTABD,'MAILLAGE','MAILLAGE',MELEME)
      IF(MACRO.NE.0)THEN
         CALL ECMO(MTABD,'MACRO','MAILLAGE',MACRO)
      ELSEIF(IQUAD.EQ.1)THEN
         CALL ECMO(MTABD,'QUADRATIQUE','MAILLAGE',MELEME)
         CALL ECMO(MTABD,'MAILLAGE','MAILLAGE',MELEMQ)
         MQ=MELEMQ
         MELEMQ=MELEME
         MELEME=MQ
      ENDIF
 
      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 ECMF(MTABD,'TOLER',TOLER)
 
CG     TYPE=' '
CG     write(6,*)' avt MTBT0 MFICEL ',MTBT0
CG     CALL ACMO(MTBT0,'MFICEL',TYPE,MFICEL)
CG     IF(TYPE.NE.'MAILLAGE')MFICEL=0
CG     IF(MACRO.NE.0.AND.MFICEL.NE.0)THEN
 
      IF(MACRO.NE.0)THEN
C     write(6,*)' OK ds MACRO ',toler
         TYPI='MAILLAGE'
         CALL ACMO(MTBT0,'MCTREI',TYPI,MCTREI)
         CALL ECMO(MTABD,'MCTREI','MAILLAGE',MCTREI)
         CALL ECROBJ('MAILLAGE',MELEMC)
         CALL ECROBJ('MAILLAGE',MCTREI)
         CALL PRFUSE
         CALL ECRREE(TOLER)
         CALL PRELIM(0)
C?    CALL PRTRAC
C     write(6,*)' premier PRELIM '
         CALL ECROBJ('MAILLAGE',MELEF1)
         CALL PRFUSE
         CALL ECRREE(TOLER)
         CALL PRELIM(0)
C     write(6,*)' second PRELIM '
         CALL LIROBJ('MAILLAGE',MMMMM,1,IRET)
         TYPE=' '
         CALL ACMO(MTBT0,'MCHPOC',TYPE,MCHPOC)
         IF(TYPE.EQ.'CHPOINT ')THEN
            CALL ECMO(MTABD,'MCHPOC','CHPOINT ',MCHPOC)
            TYPI='MAILLAGE'
            CALL ACMO(MTBT0,'MELSTB',TYPI,MELSTB)
            CALL ECMO(MTABD,'MELSTB','MAILLAGE',MELSTB)
CG si utilise, remplacer MAILLAGE par TYPI
            TYPI='MAILLAGE'
C     CALL ACMO(MTBT0,'MFACEI',TYPI,MFACEI)
C     CALL ACMO(MTBT0,'MELTFI',TYPI,MELTFI)
C     CALL ACMO(MTBT0,'MELELI',TYPI,MELELI)
C     CALL ACMO(MTBT0,'MCTREI',TYPI,MCTREI)
C     CALL ACMO(MTBT0,'MCHPOF','CHPOINT ',MCHPOF)
C     CALL ECMO(MTABD,'FACEI','MAILLAGE',MFACEI)
C     CALL ECMO(MTABD,'ELTFAI','MAILLAGE',MELTFI)
C     CALL ECMO(MTABD,'FACELI','MAILLAGE',MFICEL)
C     CALL ECMO(MTABD,'MELELI','MAILLAGE',MELELI)
C     CALL ECMO(MTABD,'MCHPOF','CHPOINT ',MCHPOF)
         ENDIF
 
      ENDIF
 
      CALL ECRCHA('POI1')
      CALL ECROBJ('MAILLAGE',MELEME)
      CALL PRCHAN
      CALL LIROBJ('MAILLAGE',MELEMS,1,IRET)
      IF(IRET.EQ.0)RETURN
      CALL ECMO(MTABD,'SOMMET','MAILLAGE',MELEMS)
      IF(MELEMS.EQ.0)RETURN
 
      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)
 
      CALL ECROBJ('MAILLAGE',MELEME)
      CALL REFE
      CALL LIROBJ('LISTMOTS',TABOG,0,IRET)
      CALL ECMO(MTABD,'OBJINCLU','LISTMOTS',TABOG)
 
      NBTYP=0
      SEGACT MELEME
      NBSOUS=LISOUS(/1)
      IF(NBSOUS.EQ.0)NBSOUS=1
      DO 3 L=1,NBSOUS
         IF(NBSOUS.NE.1)THEN
            IPT1=LISOUS(L)
            SEGACT IPT1
         ELSE
            IPT1=MELEME
         ENDIF
         NBTYP=NBTYP+1
         NEM=NOMS(IPT1.ITYPEL)//'    '
C     CALL KALPBG(NEM,'FONFORM0',IZFFM)
C     CALL ECMO(MTABD,'FONFORM0','FONFORM0',IZFFM)
C     CALL KALPBG(NEM,'FONFORM ',IZFFM)
C     CALL ECMO(MTABD,'FONFORM','FONFORM',IZFFM)
         TYPEL(NBTYP)=NEM
         IF(NBSOUS.NE.1)SEGDES IPT1
 3    CONTINUE
      SEGDES MELEME
 
      IF(IMPR.NE.0)THEN
         WRITE(6,1909)NOM,IDIM,NPTD,NELD
 1909    FORMAT(/1X,9(8H********)/5X,'DOMAINE ',A8,' CREE  DIM ESPACE:',
     &        I2,'  NB DE NOEUDS  :',I6,/42X,
     &        ' NB D ELEMENTS :',I6,/)
         WRITE(6,1919)
         DO M=1,NBTYP
            WRITE(6,1920) TYPEL(M)
         ENDDO
 1919    FORMAT(5X,'TYPE DES ELEMENTS CONSTITUANT LE DOMAINE',/)
 1920    FORMAT(5X,A8/)
         IF(TABOG.NE.0) THEN
            WRITE(6,1983)
 1983       FORMAT(10X,' LISTE DES OBJETS INCLUS DANS LE DOMAINE ',/)
            SEGACT TABOG
            NBO=TABOG.MOTS(/2)
            WRITE(6,1982)(TABOG.MOTS(MM),MM=1,NBO)
 1982       FORMAT(7(2X,A8))
            SEGDES TABOG
            WRITE(6,1928)
 1928       FORMAT(//1X,9('********')/)
         ENDIF
      ENDIF
      SEGDES MTABD
      CALL ECROBJ('TABLE   ',MTABD)
      RETURN
      END
 
 
 
 
 
 
 
 
 
 

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