Sources Esope | Cast3M

khis
C KHIS      SOURCE    CB215821  16/04/15    21:15:28     8907
      SUBROUTINE KHIS
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C*************************************************************************
C
C   Operateur KHIS
C
C   Objet : cree une table (de sous-type KHIS) pour les historiques
C
C   Syntaxe :
C
C   tab = KHIS 'NOMINCO' &lt;nc> (lect i pas ii iii) |
C               !                                 |
C               |                                 |
C               |-----------&lt;---------------------|
C               |
C               v
C
C               ;
C
C
C   Commentaires:
C
C       nc  numero de la comosante
C
C
C
C
C
C*************************************************************************
 
-INC PPARAM
-INC CCOPTIO
-INC SMTABLE
-INC SMEVOLL
-INC SMLENTI
-INC SMLREEL
-INC SMELEME
      CHARACTER*8 NOM,NUMER,NOM7
      CHARACTER*9 NOM1
 
      IVAL=0
 
      CALL CRTABL(MTABLE)
      CALL ECMM(MTABLE,'SOUSTYPE','KHIS')
 
 1    CONTINUE
 
      CALL LIRCHA(NOM,0,LNOM)
      IF(LNOM.EQ.0)GO TO 89
 
      NUCOMP=0
      CALL LIRENT(IENT,0,IRET)
      IF(IRET.EQ.1)NUCOMP=IENT
 
      CALL LIROBJ('MAILLAGE',IP,1,IRET)
      IF(IRET.EQ.0)THEN
      WRITE(6,*)' On attend un objet MAILLAGE'
      RETURN
      ENDIF
 
      NOM7=NOM(1:7)
      IF(NUCOMP.EQ.1)NOM='1'//NOM7
      IF(NUCOMP.EQ.2)NOM='2'//NOM7
      IF(NUCOMP.EQ.3)NOM='3'//NOM7
 
      NOM1='$'//NOM
       N=0
      MELEME=IP
      SEGACT MELEME
      NBS = LISOUS(/1)
      IF(NBS.EQ.0)NBS=1
      DO 11 L=1,NBS
      IPT1=MELEME
      IF(NBS.NE.1)IPT1=LISOUS(L)
      SEGACT IPT1
C     write(6,*)'IPT1.NUM(/2)',IPT1.NUM(/2)
      NN=IPT1.NUM(/2)
      IF((IPT1.NUM(/1)).NE.1)THEN
       WRITE(6,*)'LES ÉLÉMENTS DU MAILLAGE NE SONT PAS POI1'
       WRITE(6,*)'INTERRUPTION DE KHIS'
       RETURN
      ENDIF
      N=N+NN
      SEGDES IPT1
 11   CONTINUE
 
 
      CALL ECMO(MTABLE,NOM1,'MAILLAGE',MELEME)
C     write(6,*)'N :',N
      SEGINI MEVOLL
      IEVTEX=TITREE
      ITYEVO='REEL    '
 
      JG=0
      SEGINI MLREE1
 
      DO 2 I=1,N
 
      WRITE(NUMER,FMT='(I8)')I
 
      SEGINI KEVOLL
      IEVOLL(I)=KEVOLL
 
      SEGINI MLREE2
      IPROGX=MLREE1
      IPROGY=MLREE2
      TYPX='LISTREEL'
      TYPY='LISTREEL'
      NOMEVX='TEMPS'
      NOMEVY=NOM
      NUMEVY='REEL'
      KEVTEX(1:8)=NUMER
      SEGDES MLREE2
      SEGDES KEVOLL
 2    CONTINUE
      SEGDES MLREE1,MEVOLL
      CALL ECMO(MTABLE,NOM,'EVOLUTIO',MEVOLL)
      GO TO 1
 
 89   CONTINUE
 
      CALL CRTABL(MTAB1)
      CALL ECMO(MTABLE,'TABD','TABLE',MTAB1)
      CALL ECCTAB(MTAB1,'ENTIER',1,      0.D0,' ', .TRUE.,0,
     1                   'MOT',IVAL,0.D0,'MARQ PLUS',.TRUE.,0)
      CALL ECCTAB(MTAB1,'ENTIER',2,      0.D0,' ', .TRUE.,0,
     1                   'MOT',IVAL,0.D0,'MARQ CROI',.TRUE.,0)
      CALL ECCTAB(MTAB1,'ENTIER',3,      0.D0,' ', .TRUE.,0,
     1                   'MOT',IVAL,0.D0,'MARQ LOSA',.TRUE.,0)
      CALL ECCTAB(MTAB1,'ENTIER',4,      0.D0,' ', .TRUE.,0,
     1                   'MOT',IVAL,0.D0,'MARQ CARR',.TRUE.,0)
      CALL ECCTAB(MTAB1,'ENTIER',5,      0.D0,' ', .TRUE.,0,
     1                   'MOT',IVAL,0.D0,'MARQ TRIA',.TRUE.,0)
      CALL ECCTAB(MTAB1,'ENTIER',6,      0.D0,' ', .TRUE.,0,
     1                   'MOT',IVAL,0.D0,'MARQ TRIB',.TRUE.,0)
      CALL ECCTAB(MTAB1,'ENTIER',7,      0.D0,' ', .TRUE.,0,
     1                   'MOT',IVAL,0.D0,'MARQ ETOI',.TRUE.,0)
 
      SEGDES MTABLE,MTAB1
 
      CALL ECROBJ('TABLE',MTABLE)
      RETURN
      END