Sources Esope | Cast3M

evol22
C EVOL22    SOURCE    BP208322  22/09/09    21:15:03     11448          
      SUBROUTINE EVOL22(IBOO,ILEX,ILEN1,ILEN2)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
C=======================================================================
C ILEX CONTIENT LA SUITE DES CHPOINTS DES CONTRIBUTIONS MODALES.
C POUR LES COUPLES POINTS COMPOSANTES CONTENUS DANS NUMOO,
C ON RECOMBINE LES MODES dont les deformee sont CONTENUeS DANS ILEN1
C RESULTAT DANS LE(S) LISTREEL KLIST.
C APPELE PAR EVRECO
C APPELLE : ERREUR(61,243,18) IANUL PROSC1
C CREATION:12/10/89, PROGRAMMEUR:LENA
C BP, 2017-07-18 : gros menage de la subroutine 
C=======================================================================
C
-INC PPARAM
-INC CCOPTIO
-INC SMCHPOI
-INC SMLREEL
-INC SMLENTI
-INC SMELEME
-INC SMTABLE
-INC SMCOORD
      SEGMENT ICPR1(nbpts)
      SEGMENT/ITRAV1/(TRAV(LDEPL,N)*D)
      SEGMENT/ITRAV2/(TRAVV(LDEPL)*D)
      SEGMENT IPOS(NSOUP1)
      SEGMENT ITRAV(2,LDEPL)
      SEGMENT NUMOO
       INTEGER NUMO(N),KLIST(N)
       CHARACTER*(LOCHPO) NUDDL(N)
      ENDSEGMENT
      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 DEFORMEES MODALES
C     MLENT2 = LISTE DES POINTS REPERES
      MLENT1=ILEN1
      MLENT2=ILEN2
      SEGACT MLENT1,MLENT2
      LDEPL=MLENT1.LECT(/1)
 
      LICPR=nbpts
      SEGINI ICPR1
      SEGINI ITRAV1
 
C ---------------------------------------------------------------------
C     FABRICATION DU TABLEAU ITRAV1.TRAV(LDEPL,N)
C     DES MODES REDUITS AUX POINTS DE SORTIE
C ---------------------------------------------------------------------
 
C --- BOUCLE SUR LES MODES ----------------------------------
      LDEP=MLENT1.LECT(/1)
      DO 40 I=1,LDEP
 
        NUMPP=MLENT2.LECT(I)
        ICPR1(NUMPP)=I
        ichp=MLENT1.LECT(I)
 
C   --- BOUCLE SUR LES DDL DEMANDES ----------------------------------
        DO 41 IP=1,N
c         recup du noeud et du nom de composante
          mpoint=numo(ip)
          NUJ=NUDDL(IP)
          call EXTRA9(ICHP,MPOINT,nuj,0,.FALSE.,XFLOT,IRET)
c         TRAV(I^eme mode,IP^eme ddl)=[ \phi_I(x_IP) ]_{I=1...LDEP}
          TRAV(I,IP)=xflot
  41    continue
 
 40   CONTINUE
C
C ---------------------------------------------------------------------
C     FABRICATION DE ITRAV(2,LDEPL) ET DE IPOS(NSOUP+1)
C ---------------------------------------------------------------------
C     ITRAV(1,kk) = I  le kk^eme noeud du chpoint est le I^eme noeud 
c                      de la isou^eme zone du chpoint \phi_1
C     ITRAV(1,kk) = J  le kk^eme noeud du chpoint est le noeud #J
C     IPOS : la isou^eme zone du chpoint \phi_1 s'etend des noeuds 
c            kk_debut=IPOS(isou)+1  a  kk_fin=IPOS(isou+1)
      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 ---------------------------------------------------------------------
C     CREATION DE N LISREELS (OU N=NOMBRE DE DDLS A SORTIR)
C     DE TAILLE LTEM = NOMBRE DE PAS DE TEMPS A SORTIR
C ---------------------------------------------------------------------
C
      MLENTI=ILEX
      SEGACT MLENTI
      LTEM=LECT(/1)
      JG=LTEM
      DO 99 JJ=1,N
        SEGINI MLREEL
        KLIST(JJ)=MLREEL
 99   CONTINUE
C
C ---------------------------------------------------------------------
C     FABRICATION DE ITRAV2.TRAVV ET CALCUL DE x(t) DEMANDE
C ---------------------------------------------------------------------
C
      SEGINI,ITRAV2
c --- BOUCLE SUR LES PAS DE TEMPS t_l ---
      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
            SEGDES,MPOVAL,MSOUPO
          ENDIF
 70     CONTINUE
        SEGDES MCHPOI
c       TRAVV(point repere du mode k = noeud j)=\alpha_k(t_l)
        DO 162 IP=1,N
c         x_IP(t_l) = [ \alpha_1(t_l) ... \alpha_kmax(t_l) ]^T 
c                   * [ \phi_1(x_IP)  ... \phi_kmax((x_IP) ] 
          CALL PROSC1(TRAVV,TRAV(1,IP),RET,LDEPL)
          MLREEL=KLIST(IP)
          PROG(L)=RET
 162    CONTINUE
  90  CONTINUE
C
C ---------------------------------------------------------------------
c     SUPPRESSION ET FERMETURE DES SEGMENTS
C ---------------------------------------------------------------------
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