Télécharger khis.eso

Retour à la liste

Numérotation des lignes :

  1. C KHIS SOURCE CB215821 16/04/15 21:15:28 8907
  2. SUBROUTINE KHIS
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8 (A-H,O-Z)
  5. C*************************************************************************
  6. C
  7. C Operateur KHIS
  8. C
  9. C Objet : cree une table (de sous-type KHIS) pour les historiques
  10. C
  11. C Syntaxe :
  12. C
  13. C tab = KHIS 'NOMINCO' <nc> (lect i pas ii iii) |
  14. C ! |
  15. C | |
  16. C |-----------<---------------------|
  17. C |
  18. C v
  19. C
  20. C ;
  21. C
  22. C
  23. C Commentaires:
  24. C
  25. C nc numero de la comosante
  26. C
  27. C
  28. C
  29. C
  30. C
  31. C*************************************************************************
  32. -INC CCOPTIO
  33. -INC SMTABLE
  34. -INC SMEVOLL
  35. -INC SMLENTI
  36. -INC SMLREEL
  37. -INC SMELEME
  38. CHARACTER*8 NOM,NUMER,NOM7
  39. CHARACTER*9 NOM1
  40.  
  41. IVAL=0
  42.  
  43. CALL CRTABL(MTABLE)
  44. CALL ECMM(MTABLE,'SOUSTYPE','KHIS')
  45.  
  46. 1 CONTINUE
  47.  
  48. CALL LIRCHA(NOM,0,LNOM)
  49. IF(LNOM.EQ.0)GO TO 89
  50.  
  51. CALL LIRENT(IENT,0,IRET)
  52. IF(IRET.EQ.1)NUCOMP=IENT
  53.  
  54. CALL LIROBJ('MAILLAGE',IP,1,IRET)
  55. IF(IRET.EQ.0)THEN
  56. WRITE(6,*)' On attend un objet MAILLAGE'
  57. RETURN
  58. ENDIF
  59.  
  60. NOM7=NOM(1:7)
  61. IF(NUCOMP.EQ.1)NOM='1'//NOM7
  62. IF(NUCOMP.EQ.2)NOM='2'//NOM7
  63. IF(NUCOMP.EQ.3)NOM='3'//NOM7
  64.  
  65. NOM1='$'//NOM
  66. N=0
  67. MELEME=IP
  68. SEGACT MELEME
  69. NBS = LISOUS(/1)
  70. IF(NBS.EQ.0)NBS=1
  71. DO 11 L=1,NBS
  72. IPT1=MELEME
  73. IF(NBS.NE.1)IPT1=LISOUS(L)
  74. SEGACT IPT1
  75. C write(6,*)'IPT1.NUM(/2)',IPT1.NUM(/2)
  76. NN=IPT1.NUM(/2)
  77. IF((IPT1.NUM(/1)).NE.1)THEN
  78. WRITE(6,*)'LES ÉLÉMENTS DU MAILLAGE NE SONT PAS POI1'
  79. WRITE(6,*)'INTERRUPTION DE KHIS'
  80. RETURN
  81. ENDIF
  82. N=N+NN
  83. SEGDES IPT1
  84. 11 CONTINUE
  85.  
  86.  
  87. CALL ECMO(MTABLE,NOM1,'MAILLAGE',MELEME)
  88. C write(6,*)'N :',N
  89. SEGINI MEVOLL
  90. IEVTEX=TITREE
  91. ITYEVO='REEL '
  92.  
  93. JG=0
  94. SEGINI MLREE1
  95.  
  96. DO 2 I=1,N
  97.  
  98. WRITE(NUMER,FMT='(I8)')I
  99.  
  100. SEGINI KEVOLL
  101. IEVOLL(I)=KEVOLL
  102.  
  103. SEGINI MLREE2
  104. IPROGX=MLREE1
  105. IPROGY=MLREE2
  106. TYPX='LISTREEL'
  107. TYPY='LISTREEL'
  108. NOMEVX='TEMPS'
  109. NOMEVY=NOM
  110. NUMEVY='REEL'
  111. KEVTEX(1:8)=NUMER
  112. SEGDES MLREE2
  113. SEGDES KEVOLL
  114. 2 CONTINUE
  115. SEGDES MLREE1,MEVOLL
  116. CALL ECMO(MTABLE,NOM,'EVOLUTIO',MEVOLL)
  117. GO TO 1
  118.  
  119. 89 CONTINUE
  120.  
  121. CALL CRTABL(MTAB1)
  122. CALL ECMO(MTABLE,'TABD','TABLE',MTAB1)
  123. CALL ECCTAB(MTAB1,'ENTIER',1, 0.D0,' ', .TRUE.,0,
  124. 1 'MOT',IVAL,0.D0,'MARQ PLUS',.TRUE.,0)
  125. CALL ECCTAB(MTAB1,'ENTIER',2, 0.D0,' ', .TRUE.,0,
  126. 1 'MOT',IVAL,0.D0,'MARQ CROI',.TRUE.,0)
  127. CALL ECCTAB(MTAB1,'ENTIER',3, 0.D0,' ', .TRUE.,0,
  128. 1 'MOT',IVAL,0.D0,'MARQ LOSA',.TRUE.,0)
  129. CALL ECCTAB(MTAB1,'ENTIER',4, 0.D0,' ', .TRUE.,0,
  130. 1 'MOT',IVAL,0.D0,'MARQ CARR',.TRUE.,0)
  131. CALL ECCTAB(MTAB1,'ENTIER',5, 0.D0,' ', .TRUE.,0,
  132. 1 'MOT',IVAL,0.D0,'MARQ TRIA',.TRUE.,0)
  133. CALL ECCTAB(MTAB1,'ENTIER',6, 0.D0,' ', .TRUE.,0,
  134. 1 'MOT',IVAL,0.D0,'MARQ TRIB',.TRUE.,0)
  135. CALL ECCTAB(MTAB1,'ENTIER',7, 0.D0,' ', .TRUE.,0,
  136. 1 'MOT',IVAL,0.D0,'MARQ ETOI',.TRUE.,0)
  137.  
  138. SEGDES MTABLE,MTAB1
  139.  
  140. CALL ECROBJ('TABLE',MTABLE)
  141. RETURN
  142. END
  143.  
  144.  
  145.  
  146.  
  147.  

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