Télécharger kdom.eso

Retour à la liste

Numérotation des lignes :

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

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