Télécharger khis.eso

Retour à la liste

Numérotation des lignes :

khis
  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.  
  33. -INC PPARAM
  34. -INC CCOPTIO
  35. -INC SMTABLE
  36. -INC SMEVOLL
  37. -INC SMLENTI
  38. -INC SMLREEL
  39. -INC SMELEME
  40. CHARACTER*8 NOM,NUMER,NOM7
  41. CHARACTER*9 NOM1
  42.  
  43. IVAL=0
  44.  
  45. CALL CRTABL(MTABLE)
  46. CALL ECMM(MTABLE,'SOUSTYPE','KHIS')
  47.  
  48. 1 CONTINUE
  49.  
  50. CALL LIRCHA(NOM,0,LNOM)
  51. IF(LNOM.EQ.0)GO TO 89
  52.  
  53. CALL LIRENT(IENT,0,IRET)
  54. IF(IRET.EQ.1)NUCOMP=IENT
  55.  
  56. CALL LIROBJ('MAILLAGE',IP,1,IRET)
  57. IF(IRET.EQ.0)THEN
  58. WRITE(6,*)' On attend un objet MAILLAGE'
  59. RETURN
  60. ENDIF
  61.  
  62. NOM7=NOM(1:7)
  63. IF(NUCOMP.EQ.1)NOM='1'//NOM7
  64. IF(NUCOMP.EQ.2)NOM='2'//NOM7
  65. IF(NUCOMP.EQ.3)NOM='3'//NOM7
  66.  
  67. NOM1='$'//NOM
  68. N=0
  69. MELEME=IP
  70. SEGACT MELEME
  71. NBS = LISOUS(/1)
  72. IF(NBS.EQ.0)NBS=1
  73. DO 11 L=1,NBS
  74. IPT1=MELEME
  75. IF(NBS.NE.1)IPT1=LISOUS(L)
  76. SEGACT IPT1
  77. C write(6,*)'IPT1.NUM(/2)',IPT1.NUM(/2)
  78. NN=IPT1.NUM(/2)
  79. IF((IPT1.NUM(/1)).NE.1)THEN
  80. WRITE(6,*)'LES ÉLÉMENTS DU MAILLAGE NE SONT PAS POI1'
  81. WRITE(6,*)'INTERRUPTION DE KHIS'
  82. RETURN
  83. ENDIF
  84. N=N+NN
  85. SEGDES IPT1
  86. 11 CONTINUE
  87.  
  88.  
  89. CALL ECMO(MTABLE,NOM1,'MAILLAGE',MELEME)
  90. C write(6,*)'N :',N
  91. SEGINI MEVOLL
  92. IEVTEX=TITREE
  93. ITYEVO='REEL '
  94.  
  95. JG=0
  96. SEGINI MLREE1
  97.  
  98. DO 2 I=1,N
  99.  
  100. WRITE(NUMER,FMT='(I8)')I
  101.  
  102. SEGINI KEVOLL
  103. IEVOLL(I)=KEVOLL
  104.  
  105. SEGINI MLREE2
  106. IPROGX=MLREE1
  107. IPROGY=MLREE2
  108. TYPX='LISTREEL'
  109. TYPY='LISTREEL'
  110. NOMEVX='TEMPS'
  111. NOMEVY=NOM
  112. NUMEVY='REEL'
  113. KEVTEX(1:8)=NUMER
  114. SEGDES MLREE2
  115. SEGDES KEVOLL
  116. 2 CONTINUE
  117. SEGDES MLREE1,MEVOLL
  118. CALL ECMO(MTABLE,NOM,'EVOLUTIO',MEVOLL)
  119. GO TO 1
  120.  
  121. 89 CONTINUE
  122.  
  123. CALL CRTABL(MTAB1)
  124. CALL ECMO(MTABLE,'TABD','TABLE',MTAB1)
  125. CALL ECCTAB(MTAB1,'ENTIER',1, 0.D0,' ', .TRUE.,0,
  126. 1 'MOT',IVAL,0.D0,'MARQ PLUS',.TRUE.,0)
  127. CALL ECCTAB(MTAB1,'ENTIER',2, 0.D0,' ', .TRUE.,0,
  128. 1 'MOT',IVAL,0.D0,'MARQ CROI',.TRUE.,0)
  129. CALL ECCTAB(MTAB1,'ENTIER',3, 0.D0,' ', .TRUE.,0,
  130. 1 'MOT',IVAL,0.D0,'MARQ LOSA',.TRUE.,0)
  131. CALL ECCTAB(MTAB1,'ENTIER',4, 0.D0,' ', .TRUE.,0,
  132. 1 'MOT',IVAL,0.D0,'MARQ CARR',.TRUE.,0)
  133. CALL ECCTAB(MTAB1,'ENTIER',5, 0.D0,' ', .TRUE.,0,
  134. 1 'MOT',IVAL,0.D0,'MARQ TRIA',.TRUE.,0)
  135. CALL ECCTAB(MTAB1,'ENTIER',6, 0.D0,' ', .TRUE.,0,
  136. 1 'MOT',IVAL,0.D0,'MARQ TRIB',.TRUE.,0)
  137. CALL ECCTAB(MTAB1,'ENTIER',7, 0.D0,' ', .TRUE.,0,
  138. 1 'MOT',IVAL,0.D0,'MARQ ETOI',.TRUE.,0)
  139.  
  140. SEGDES MTABLE,MTAB1
  141.  
  142. CALL ECROBJ('TABLE',MTABLE)
  143. RETURN
  144. END
  145.  
  146.  
  147.  
  148.  
  149.  

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