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