C EVOL22    SOURCE    CHAT      05/01/12    23:47:08     5004           
      SUBROUTINE EVOL22(IBOO,ILEX,IBOBAS,ILEN1,ILEN2)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C=======================================================================
C ILEX CONTIENT LA SUITE DES CHPOINTS DESCONTRIBUTIONS MODALES.
CPOUR LES COUPLES POINTS COMPOSANTES CONTENUS DANS NUMOO,
C ON RECOMBINE LES MODES CONTENUS DANS
C UNE TABLE RESULTAT DE TRADUIRE
C RESULTAT DANS LE(S) LISTREEL KLIST.
C  APPELE PAR EVRECO
C APPELLE : ERREUR(61,243,18) IANUL PROSC1
C CREATION:12/10/89
C PROGRAMMEUR:LENA
C=======================================================================
C
-INC CCOPTIO
-INC SMCHPOI
-INC SMLREEL
-INC SMLENTI
-INC SMELEME
-INC SMTABLE
-INC SMCOORD
      SEGMENT ICPR(XCOOR(/1)/(IDIM+1))
      SEGMENT ICPR1(XCOOR(/1)/(IDIM+1))
      SEGMENT/ITRAV1/(TRAV(LDEPL,N)*D)
      SEGMENT/ITRAV2/(TRAVV(LDEPL)*D)
      SEGMENT/ITRAV3/(ICC(N),ISS(N),IPP(N),NBB(N))
      SEGMENT IPOS(NSOUP1)
      SEGMENT ITRAV(2,LDEPL)
      SEGMENT NUMOO
       INTEGER NUMO(N),KLIST(N)
       CHARACTER*4 NUDDL(N)
      ENDSEGMENT
      DIMENSION IMEL(2)
      CHARACTER*4 NUJ
      CHARACTER*8 IBASMO
      DATA IBASMO/'BASE-MOD'/
C
      LDEPL=0
      NUMOO=IBOO
      SEGACT NUMOO*MOD
      N=NUMO(/1)
C MLENT1=LISTE DES P.DEFMODALES,MLENT2 = LISTE DES P.POINTS REPERES
      MLENT1=ILEN1
      MLENT2=ILEN2
      SEGACT MLENT1,MLENT2
      MTAB1=IBOBAS
      SEGACT MTAB1
      ITOTO=1
      IMEL(1)=0
      IMEL(1)=MLENT2.LECT(1)
      LDEPL=MLENT1.LECT(/1)
      SEGDES MTAB1
      LICPR=XCOOR(/1)/(IDIM+1)
      SEGINI ICPR,ICPR1
C
      JJJ=0
      SEGINI ITRAV1
      SEGINI ITRAV3
      KK=0
      DO 61 I=1,N
      KK=KK+1
C      ICC(KK)=IC
      IPP(KK)=I
   61 CONTINUE

C ***** ON REPART SUR LES MODES
      LDEP=MLENT1.LECT(/1)
      DO 40 I=1,LDEP
      JJJ=JJJ+1
      NUMPP=MLENT2.LECT(I)
C      ICPR1(NUM(1,I))=JJJ
      ICPR1(NUMPP)=JJJ

C **** FABRICATION DU TABLEAU TRAV(LDEPL,N) DES MODES REDUITS AUX
C **** POINTS DE SORTIE (BOUCLE 40)

      ichp=MLENT1.LECT(I)
      DO 41 IP=1,N
      mpoint=numo(ip)
      NUJ=NUDDL(IP)
      call EXTRA9(ICHP,MPOINT,nuj,KERRE,XFLOT)
      TRAV(JJJ,IPP(IP))=xflot
  41  continue

 40   CONTINUE
      SEGSUP ITRAV3
      SEGSUP  ICPR
C
C **** FABRICATION DEITRAV(2,LDEPL),ET DE IPOS(NSOUP+1)
C
      MLENTI=ILEX
      SEGACT MLENTI
      MCHPOI=LECT(1)
      SEGACT MCHPOI
      NSOUP=IPCHP(/1)
      NSOUP1=NSOUP+1
      SEGINI IPOS
      SEGINI ITRAV
      KK=0
      IPOS(1)=0
      DO 1 ISOU=1,NSOUP
      MSOUPO=IPCHP(ISOU)
      SEGACT MSOUPO
      MELEME=IGEOC
      SEGACT MELEME
      DO 2 I=1,NUM(/2)
      J=ICPR1(NUM(1,I))
      IF (J.NE.0) THEN
       KK=KK+1
       ITRAV(1,KK)=I
       ITRAV(2,KK)=J
      ENDIF
 2    CONTINUE
      SEGDES MELEME,MSOUPO
      IPOS(ISOU+1)=KK
 1    CONTINUE
      SEGSUP ICPR1
C 
C **** BOUCLE SUR LES INSTANTS DE LA TABLE
C
      MLENTI=ILEX
      SEGACT MLENTI
      LTEM=LECT(/1)
      JG=LTEM
      DO 99 JJ=1,N
      SEGINI MLREEL
      KLIST(JJ)=MLREEL
 99   CONTINUE
C
      SEGINIITRAV2
      DO 90 L=1,LTEM
      MCHPOI=LECT(L)
      SEGACT MCHPOI
      DO 70 I=1,NSOUP
      IF (IPOS(I+1).NE.IPOS(I)) THEN
        MSOUPO=IPCHP(I)
        SEGACT MSOUPO
        MPOVAL=IPOVAL
        SEGACT MPOVAL
        DO 160 NB=IPOS(I)+1,IPOS(I+1)
          TRAVV(ITRAV(2,NB))=VPOCHA(ITRAV(1,NB),1)
 160    CONTINUE
        SEGDESMPOVAL,MSOUPO
      ENDIF
 70   CONTINUE
      SEGDES MCHPOI
      DO 162 IP=1,N
      CALL PROSC1(TRAVV,TRAV(1,IP),RET,LDEPL)
      MLREEL=KLIST(IP)
      PROG(L)=RET
 162  CONTINUE
  90  CONTINUE
C
      SEGSUP ITRAV
      SEGSUP IPOS
      SEGSUP ITRAV1,ITRAV2
      DO 98 JJ=1,N
      MLREEL=KLIST(JJ)
      SEGDES MLREEL
  98  CONTINUE
C
      SEGDES MLENTI
 5000 CONTINUE
      RETURN
      END