Esope source files

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