C EVOL2 SOURCE FANDEUR 10/12/14 21:16:15 6812 SUBROUTINE EVOL2(IBOO,ILEX,IBOBAS,ICHAN) 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, ON C RECOMBINE LES MODES ET SOLUTIONS STATIQUES CONTENUS DANS MSOBAS . C RESULTAT DANS LE(S) LISTREEL KLIST. C APPELE PAR EVRECO C SI ICHAN=0 ON TRAVAILLE SUR UN CHPOINT C SI ICHAN=1 ON TRAVAILLE SUR UN CHAMELEM ET ON LE TRANSFORME EN C CHPOINT PAR UN APPEL A PELPO C APPELLE : ERREUR(61,243,18) IANUL PROSC1 C CREATION : 02/04/85 C PROGRAMMEUR : FARVACQUE C======================================================================= C -INC CCOPTIO -INC SMBASEM -INC SMCHPOI -INC SMSOLUT -INC SMLREEL -INC SMELEME -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 KDEPL(2),IMEL(2) CHARACTER*4 NUJ C NUMOO=IBOO SEGACT NUMOO N=NUMO(/1) MSOBAS=IBOBAS SEGACT MSOBAS LDEPL=0 DO 6 ICAS=1,2 KDEPL(ICAS)=0 MSOLUT=IBSTRM(ICAS+1) IF(MSOLUT.EQ.0) GOTO 6 SEGACT MSOLUT IF (ICHAN.EQ.0) KDEPL(ICAS)=MSOLIS(5) IF (ICHAN.EQ.1) KDEPL(ICAS)=MSOLIS(6) IMEL(ICAS)=MSOLIS(3) SEGDES MSOLUT IF(KDEPL(ICAS).EQ.0) THEN MOTERR(1:8)=ITYSOL CALL ERREUR(61) SEGDES MSOBAS RETURN ENDIF MSOLEN=KDEPL(ICAS) SEGACT MSOLEN LDEPL=LDEPL+ISOLEN(/1) SEGDES MSOLEN 6 CONTINUE SEGDES MSOBAS LICPR=XCOOR(/1)/(IDIM+1) SEGINI ICPR,ICPR1 C C **** FABRICATION DU TABLEAU ICC-ISS-IPP-NBB POUR CHAQUE PT DE SORTIE C **** (BOUCLE 30) C **** FABRICATION DU TABLEAU TRAV(LDEPL,N) DES MODES REDUITS AUX C **** POINTS DE SORTIE (BOUCLE 40) C JJJ=0 SEGINI ITRAV1 DO 50 ICAS=1,2 MSOLEN=KDEPL(ICAS) IF(MSOLEN.EQ.0) GOTO 50 SEGINI ITRAV3 SEGACT MSOLEN IF (ICHAN.EQ.0) THEN MCHPOI=ISOLEN(1) ELSE ICHAM=ISOLEN(1) C* Manque le passage en MCHAML aux noeuds avec le modele !!! C* CALL CHASUP(IPMODL,ICHAM,ICHAM2,IRET,1) C* IF (IRET.EQ.0) THEN C* CALL ERREUR(___) C* RETURN C* ENDIF C* CALL CHAMPO(ICHAM2,2,MCHPOI,IRET) CALL CHAMPO(ICHAM,2,MCHPOI,IRET) IF (IRET.EQ.0) RETURN ENDIF SEGACT MCHPOI NSOUPO=IPCHP(/1) KK=0 DO 30 ISOU=1,NSOUPO MSOUPO=IPCHP(ISOU) SEGACT MSOUPO NC=NOCOMP(/2) MELEME=IGEOC SEGACT MELEME CALL IANUL(ICPR(1),LICPR) DO 60 NB=1,NUM(/2) ICPR(NUM(1,NB))=NB 60 CONTINUE SEGDES MELEME DO 61 I=1,N IF(ICPR(NUMO(I)).NE.0) THEN KK=KK+1 NBB(KK)=ICPR(NUMO(I)) NUJ=NUDDL(I) DO 72 IC=1,NC IF(NOCOMP(IC).EQ.NUJ) THEN ICC(KK)=IC ISS(KK)=ISOU IPP(KK)=I GOTO 61 ENDIF 72 CONTINUE MOTERR(1:4)=NUJ CALL ERREUR(243) C INCOMPATIBILITE POINT_COMPOSANTE GOTO 5000 ENDIF 61 CONTINUE SEGDES MSOUPO 30 CONTINUE C IF(KK.NE.N) THEN CALL ERREUR(18) C IL MANQUE DES POINTS GOTO 5000 ENDIF C LDEP=ISOLEN(/1) MELEME=IMEL(ICAS) SEGACT MELEME DO 40 I=1,LDEP JJJ=JJJ+1 ICPR1(NUM(1,I))=JJJ IF(I.EQ.1) GOTO 42 IF (ICHAN.EQ.0) THEN MCHPOI=ISOLEN(I) ELSE ICHAM=ISOLEN(I) C* Manque le passage en MCHAML aux noeuds avec le modele !!! C* CALL CHASUP(IPMODL,ICHAM,ICHAM2,IRET,1) C* IF (IRET.EQ.0) THEN C* CALL ERREUR(___) C* RETURN C* ENDIF C* CALL CHAMPO(ICHAM2,2,MCHPOI,IRET) CALL CHAMPO(ICHAM,2,MCHPOI,IRET) IF (IRET.EQ.0) RETURN ENDIF SEGACT MCHPOI 42 CONTINUE DO 41 IP=1,N MSOUPO=IPCHP(ISS(IP)) SEGACT MSOUPO MPOVAL=IPOVAL SEGACT MPOVAL TRAV(JJJ,IPP(IP))=VPOCHA(NBB(IP),ICC(IP)) SEGDES MPOVAL,MSOUPO 41 CONTINUE IF (ICHAN.EQ.0) SEGDES MCHPOI IF (ICHAN.EQ.1) SEGSUP MCHPOI 40 CONTINUE SEGDES MSOLEN,MELEME SEGSUP ITRAV3 50 CONTINUE C SEGSUP ICPR C C **** FABRICATION DE ITRAV(2,LDEPL), ET DE IPOS(NSOUP+1) C MSOLEN=ILEX SEGACT MSOLEN MCHPOI=ISOLEN(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 MSOLEN=ILEX SEGACT MSOLEN LTEM=ISOLEN(/1) JG=LTEM DO 99 JJ=1,N SEGINI MLREEL KLIST(JJ)=MLREEL 99 CONTINUE C SEGINI ITRAV2 DO 90 L=1,LTEM MCHPOI=ISOLEN(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 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 MSOLEN 5000 CONTINUE RETURN END