Télécharger kdom.eso

Retour à la liste

Numérotation des lignes :

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

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