Télécharger la plaquette Cast3M


fr en

Télécharger kdom.eso

Retour à la liste

Numérotation des lignes : 

kdom

  1. C KDOM      SOURCE    PV        20/03/31    14:33:32     10567          
  2.       SUBROUTINE KDOM
  3. C************************************************************************
  4. C
  5. C  OBJET   : Cree une table de soustype DOMAINE
  6. C  SYNTAXE : A = KDOM OBJ1 <IMPR>
  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. -INC CCNOYAU
  28.  
  29. -INC PPARAM
  30. -INC CCOPTIO
  31. -INC SMCOORD
  32.       PARAMETER (NMO1=4)
  33.       CHARACTER*8 MO1(NMO1)
  34.       CHARACTER*(LONOM) NOMDOM
  35.       CHARACTER*8 NOM,TYPEL(20),TYPE,NOMI,MTYP
  36.       PARAMETER (LM1=9)
  37.       CHARACTER*8 LIST1(LM1),LIST2(LM1)
  38. C***
  39.       DATA MO1/'IMPR    ','INCL    ','MACRO   ','        '/
  40.       DATA LIST1/'VOLUME  ','COTE    ','DIAMAX  ','DIAMIN  ',
  41.      &     'NORMALE ','SURFACE ','ORIENTAT','DSOMMET ','DCENTRE '/
  42.       DATA LIST2/'XXVOLUM ','XXCOTE  ','XXDIAME ','XXDIEMIN',
  43.      &     'XXNORMAF','XXSURFAC','XXNORMAE','XXDIAGSI','XXVOLUM '/
  44.       CHARACTER*8 CHAI
  45. *
  46.       segact mcoord
  47. *
  48. C
  49. C**** Cas VF
  50. C
  51.       CALL LIRCHA(CHAI,0,IRET)
  52.       IF(IRET.NE.0)THEN
  53.          IF(CHAI.EQ. 'VF  ')THEN
  54.             CALL KDOM0
  55.             RETURN
  56.          ELSE
  57.             CALL REFUS
  58.          ENDIF
  59.       ENDIF
  60. C
  61. C****** Fin cas VF
  62. C
  63.       MMODEL=0
  64.       MTABI=0
  65.       MACRO=0
  66.       CALL LIROBJ('MAILLAGE',MELEME,0,IRET)
  67.  
  68.       IF(IRET.EQ.0)THEN
  69. C       write(6,*)' 2eme utilisation de DOMA '
  70.          TYPE=' '
  71.          CALL QUETYP(TYPE,1,IRET)
  72.  
  73.          IF(IRET.EQ.0)THEN
  74.             WRITE(6,*)' On attend un objet TABLE ou MMODEL'
  75.             RETURN
  76.          ENDIF
  77.  
  78.          IF(TYPE.EQ.'TABLE')THEN
  79.             CALL LIROBJ(TYPE,MTABLE,1,IRET)
  80.             INEFMD=0
  81.          ELSEIF(TYPE.EQ.'MMODEL') THEN
  82.             CALL LIROBJ(TYPE,MMODEL,1,IRET)
  83.             CALL LEKMOD(MMODEL,MTABLE,INEFMD)
  84.             IF(MTABLE.EQ.0)RETURN
  85.          ELSE
  86.             WRITE(6,*)' On attend un objet TABLE ou MMODEL'
  87.             RETURN
  88.          ENDIF
  89.  
  90.          CALL LIRCHA(NOM,1,LCHAR)
  91.          IF(LCHAR.EQ.0)THEN
  92.             WRITE(6,*)' On attend une CHAINE'
  93.             RETURN
  94.          ENDIF
  95.  
  96.          IF(NOM.EQ.'IMPR    ')THEN
  97.             CALL KDIMPR(MTABLE)
  98.             RETURN
  99.          ENDIF
  100.  
  101.          IF(NOM.EQ.'TABLE   '.AND.MMODEL.NE.0)THEN
  102.             CALL LEKMOD(MMODEL,MTABD,INEFMD)
  103.             CALL ECROBJ('TABLE   ',MTABD)
  104.             RETURN
  105.          ENDIF
  106.  
  107.          CALL OPTLI(IP,LIST1,NOM,LM1)
  108.          IF(IP.NE.0)THEN
  109.             NOMI=LIST2(IP)
  110.          ELSE
  111.             NOMI=NOM
  112.          ENDIF
  113.          MTB = -MTABLE
  114.          CALL LEKTAB(MTB,NOMI,IPOINT)
  115.          RETURN
  116.       ENDIF
  117.  
  118.       CALL QUENOM(NOMDOM)
  119.  
  120.       CALL XDIAMM(MELEME,DIAM)
  121.       DIAM=DIAM*0.0003D0
  122.       CALL LIRREE(TOLER,0,IRET)
  123.       IF(IRET.EQ.0)TOLER=DIAM
  124.  
  125.       IMPR=0
  126.  1    CONTINUE
  127.  
  128.  21   CONTINUE
  129.       CALL QUETYP(MTYP,0,IRET)
  130.       IP=0
  131.       IF(MTYP.EQ.'MOT')THEN
  132.          CALL LIRCHA(NOM,1,LCHAR)
  133.          IF(NOM.EQ.'        ')GO TO 21
  134.          CALL OPTLI(IP,MO1,NOM,NMO1)
  135.          IF(IP.EQ.4)IP=0
  136. c          IF(IP.EQ.9999)CALL KDAM
  137.       ENDIF
  138.  
  139.       IF(IP.EQ.1)THEN
  140.  
  141.          IMPR=1
  142.          GO TO 1
  143.  
  144.       ELSEIF(IP.EQ.2)THEN
  145.  
  146.          CALL LIROBJ('TABLE',MTABI,1,IRET)
  147.          IF(IRET.EQ.0)RETURN
  148.          CALL LIRREE(TOLER,0,IRET)
  149.          IF(IRET.EQ.0)TOLER=DIAM
  150.          GO TO 1
  151.  
  152.       ELSEIF(IP.EQ.3)THEN
  153.  
  154.          MACRO=1
  155.          GO TO 1
  156.  
  157.       ELSE
  158.          GO TO 2
  159.       ENDIF
  160.  
  161.  2    CONTINUE
  162.  
  163.       CALL KKDOM(MELEME,MACRO,TOLER,NOMDOM,MTABI,MTABD,INEFMD)
  164.       CALL ECME(MTABD,'PRECONDI',1)
  165. C?    CALL KKDOM(MELEME,MACRO,TOLER,NOMDOM,MTABI,MTABD)
  166.       IF(IMPR.NE.0)CALL KDIMPR(MTABD)
  167.       CALL ECROBJ('TABLE   ',MTABD)
  168. C     write(6,*)' FIN DOMA '
  169.       RETURN
  170.       END
  171.  
  172.  
  173.  
  174.  
  175.  
  176.  
  177.  
  178.  
  179.  

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