Esope source files

   1 : C KDOM      SOURCE    CHAT      06/08/24    21:46:14     5529           
   2 :       SUBROUTINE KDOM
   3 : C************************************************************************
   4 : C     
   5 : C  OBJET   : Cree une table de soustype DOMAINE
   6 : C  SYNTAXE : A = KDOM OBJ1 
   7 : C     
   8 : C                OBJ1 objet 'MAILLAGE'
   9 : C                IMPR  impressions de controle
  10 : C La table cree contient les informations suivantes:
  11 : C     
  12 : C          Indice                          Objet
  13 : C    Type    Valeur                  Type     Valeur
  14 : C  MOT       SOUSTYPE              MOT       DOMAINE
  15 : C  MOT       MAILLAGE              MAILLAGE
  16 : C  MOT       SOMMET                MAILLAGE
  17 : C  MOT       CENTRE                MAILLAGE
  18 : C  MOT       FACE                  MAILLAGE
  19 : C  MOT       FACEL                 MAILLAGE
  20 : C  MOT       NPTD                  ENTIER
  21 : C  MOT       NELD                  ENTIER
  22 : C  MOT       NBFD                  ENTIER
  23 : C  MOT       OBJINCLU              LISTMOTS
  24 : C************************************************************************
  25 :       IMPLICIT INTEGER(I-N)
  26 :       IMPLICIT REAL*8 (A-H,O-Z)
  27 :       PARAMETER (NMO1=4)
  28 :       CHARACTER*8 MO1(NMO1),NOMDOM,NOMC
  29 :       CHARACTER*8 NOM,TYPEL(20),TYPE,NOMI,MTYP
  30 :       PARAMETER (LM1=9)
  31 :       CHARACTER*8 LIST1(LM1),LIST2(LM1)
  32 : C***  
  33 :       DATA MO1/'IMPR    ','INCL    ','MACRO   ','        '/
  34 :       DATA LIST1/'VOLUME  ','COTE    ','DIAMAX  ','DIAMIN  ',
  35 :      &     'NORMALE ','SURFACE ','ORIENTAT','DSOMMET ','DCENTRE '/
  36 :       DATA LIST2/'XXVOLUM ','XXCOTE  ','XXDIAME ','XXDIEMIN',
  37 :      &     'XXNORMAF','XXSURFAC','XXNORMAE','XXDIAGSI','XXVOLUM '/
  38 :       CHARACTER*8 CHAI
  39 : C
  40 : C**** Cas VF
  41 : C
  41 :       CALL LIRCHA(CHAI,0,IRET)
  42 :       IF(IRET.NE.0)THEN
  43 :          IF(CHAI.EQ. 'VF  ')THEN
  43 :             CALL KDOM0
  44 :             RETURN
  45 :          ELSE
  45 :             CALL REFUS
  46 :          ENDIF
  47 :       ENDIF
  48 : C
  49 : C****** Fin cas VF
  50 : C                 
  51 :       MMODEL=0
  52 :       MTABI=0
  53 :       MACRO=0
  53 :       CALL LIROBJ('MAILLAGE',MELEME,0,IRET)
  54 : 
  55 :       IF(IRET.EQ.0)THEN
  56 : C       write(6,*)' 2eme utilisation de DOMA '
  57 :          TYPE=' '
  57 :          CALL QUETYP(TYPE,1,IRET)
  58 : 
  59 :          IF(IRET.EQ.0)THEN
  60 :             WRITE(6,*)' On attend un objet TABLE ou MMODEL'
  61 :             RETURN
  62 :          ENDIF
  63 :          IF(TYPE.EQ.'TABLE')THEN
  63 :          CALL LIROBJ(TYPE,MTABLE,1,IRET)
  64 :          INEFMD=0
  65 :          ELSEIF(TYPE.EQ.'MMODEL')THEN
  65 :          CALL LIROBJ(TYPE,MMODEL,1,IRET)
  65 :          CALL LEKMOD(MMODEL,MTABLE,INEFMD)
  66 : 
  67 :          IF(MTABLE.EQ.0)RETURN
  68 :          ELSE
  69 :             WRITE(6,*)' On attend un objet TABLE ou MMODEL'
  70 :             RETURN
  71 :          ENDIF
  72 : 
  72 :          CALL LIRCHA(NOM,1,LCHAR)
  73 :          IF(LCHAR.EQ.0)THEN
  74 :             WRITE(6,*)' On attend une CHAINE'
  75 :             RETURN
  76 :          ENDIF
  77 : 
  78 :          IF(NOM.EQ.'IMPR    ')THEN
  78 :          CALL KDIMPR(MTABLE)
  79 :          RETURN
  80 :          ENDIF
  81 : 
  82 :          IF(NOM.EQ.'TABLE   '.AND.MMODEL.NE.0)THEN
  82 :          CALL LEKMOD(MMODEL,MTABD,INEFMD)
  82 :          CALL ECROBJ('TABLE   ',MTABD)
  83 :          RETURN
  84 :          ENDIF
  85 : 
  85 :          CALL OPTLI(IP,LIST1,NOM,LM1)
  86 :          IF(IP.NE.0)THEN
  87 :             NOMI=LIST2(IP)
  88 :          ELSE
  89 :             NOMI=NOM
  90 :          ENDIF
  91 :          MTB = - MTABLE
  91 :          CALL LEKTAB(MTB,NOMI,IPOINT)
  92 :          RETURN
  93 :       ENDIF
  94 : 
  95 : 
  95 :       CALL XDIAMM(MELEME,DIAM)
  96 :       DIAM=DIAM*0.0003D0
  96 :       CALL LIRREE(TOLER,0,IRET)
  97 :       IF(IRET.EQ.0)TOLER=DIAM
  98 : 
  98 :       CALL QUENOM(NOMDOM)
  99 : 
 100 :       IMPR=0
 101 :  1    CONTINUE
 102 : 
 103 :  21   CONTINUE
 103 :       CALL QUETYP(MTYP,0,IRET)
 104 :       IP=0
 105 :       IF(MTYP.EQ.'MOT')THEN
 105 :          CALL LIRCHA(NOM,1,LCHAR)
 106 :          IF(NOM.EQ.'        ')GO TO 21
 106 :          CALL OPTLI(IP,MO1,NOM,NMO1)
 107 :          IF(IP.EQ.4)IP=0
 107 :          IF(IP.EQ.9999)CALL KDAM
 108 :       ENDIF
 109 : 
 110 :       IF(IP.EQ.1)THEN
 111 : 
 112 :          IMPR=1
 113 :          GO TO 1
 114 : 
 115 :       ELSEIF(IP.EQ.2)THEN
 116 : 
 116 :          CALL LIROBJ('TABLE',MTABI,1,IRET)
 117 :          IF(IRET.EQ.0)RETURN
 117 :          CALL LIRREE(TOLER,0,IRET)
 118 :          IF(IRET.EQ.0)TOLER=DIAM
 119 :          GO TO 1
 120 : 
 121 :       ELSEIF(IP.EQ.3)THEN
 122 : 
 123 :          MACRO=1
 124 :          GO TO 1
 125 : 
 126 :       ELSE
 127 :          GO TO 2
 128 :       ENDIF
 129 : 
 130 :  2    CONTINUE
 131 : 
 131 :       CALL KKDOM(MELEME,MACRO,TOLER,NOMDOM,MTABI,MTABD,INEFMD)
 131 :       CALL ECME(MTABD,'PRECONDI',1)
 131 : C?    CALL KKDOM(MELEME,MACRO,TOLER,NOMDOM,MTABI,MTABD)
 131 :       IF(IMPR.NE.0)CALL KDIMPR(MTABD)
 131 :       CALL ECROBJ('TABLE   ',MTABD)
 132 : C     write(6,*)' FIN DOMA '
 133 :       RETURN
 134 :       END
 135 :  
 136 :  
 137 :  
 138 :  
 139 :  
 140 :