C EVRECO SOURCE KICH 08/06/26 21:16:23 6133 SUBROUTINE EVRECO(ICOUL) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) C======================================================================= C OPTION RECO DE L'OPERATEUR EVOL C C.1.EVOLUTION D'UN DDL DANS L'OBJET SOLUTION: C MEVOL = EVOL COUL RECO MSOLUT BASE TYPE PT1 COMP (INSTANTS) ; C ---- ---- ---- ---- C C.2.EVOLUTION DE PLUSIEURS DDL DANS L'OBJET SOLUTION: C MEVOL = EVOL COUL RECO MSOLUT BASE TYPE CHP1 (INSTANTS) ; C.3.EVOLUTION DE PLUSIEURS DDL DANS L'OBJET TABLE C MEVOL = EVOL COUL RECO TRESU TBASE TYPE PT1 COMP (INSTANTS) ; C ---- ---- ---- ---- C C COUL : COULEUR DE LA (OU DES) COURBE(S) C MEVOL : OBJET DE TYPE EVOLUTION C MSOLUT : OBJET SOLUTION C TYPE : MOT CLE:TYPE DE LA VARIABLE (DEPL,VITE,ACCE,CONT..) C COMP : NOM DE LA COMPOSANTE CHOISIE C INSTANTS: PROCEDURE FACULTATIVE POUR CHOISIR LES CAS DE SORTIE C PROGX :OBJET LISTREEL, LISTE DES TEMPS A SORTIR C LECTC :OBJET LISTENTI, LISTE DES CAS A SORTIR C RIEN :L'OBJET EVOLUTION PORTE SUR TOUS LES CAS PRESENTS C DANS LE MSOLUT C C BASE : BASE ELEMENTAIRE C BASE STRU N C C PT1 : POINT OU MELEME A EXTRAIRE C CHP1 : CHPOINT CONTENANT LES POINTS ET DDL (FABRIQUE PAR C EXEMPLE PAR MANU CHPO ) C C LES OBJETS PT1,CHP1 SERVENT A REPERER DANS LES CHAMPS C CHOISIS, LE(S) POINT(S) QUI INTERESSENT L'EVOLUTION. C C CREATION : 16/10/85 C PROGRAMMEUR : FARVACQUE C======================================================================= -INC CCOPTIO -INC SMSOLUT -INC SMTABLE -INC SMBASEM -INC SMEVOLL -INC SMELEME -INC SMLENTI -INC SMCHPOI LOGICAL L0,L1 SEGMENT NUMOO INTEGER NUMO(N),KLIST(N) CHARACTER*4 NUDDL(N) ENDSEGMENT CHARACTER*4 TI1 CHARACTER*8 ITYPE,ITYP1,CTYP,TYPRET,CHARRE CHARACTER*72 TI,MCHA,NOMCO C C======================================================================= ICONT=0 KPSMO=0 ISOLU=0 ITABL=0 * *---- type du prochain objet @ lire ( TABLE ou SOLUTION ) * CALL QUETYP (CTYP,1,IRETOU) IF (IERR.NE.0) RETURN * * --- on lit le nom du champ @ traiter et le nom de la composante CALL LIRCHA(MCHA,1,IRETOU) IF(IERR.NE.0) RETURN IF (MCHA.EQ.'CONT') ICONT = 1 IF (MCHA.EQ.'REAC') ICONT = 2 LCHALU=IRETOU CALL LIRCHA(NOMCO,0,IRETOU) IF(IRETOU.EQ.0) NOMCO=' ' * * --- on recup}re le point ou le maillage ou le chpoint CALL LIROBJ('POINT ',IRET,0,IRETOU) IF (IRETOU.EQ.0) THEN CALL LIROBJ('MAILLAGE',IRET,0,IRETOU) IF (IRETOU.EQ.0) THEN CALL LIROBJ('CHPOINT ',IRET,0,IRETOU) IF (IRETOU.EQ.0) THEN * on ne trouve pas le support qui contient les points CALL ERREUR(248) RETURN ELSE ITYPE='CHPOINT' ENDIF ELSE ITYPE='MAILLAGE' ENDIF ELSE ITYPE='POINT' ENDIF iptu = iret *-------------------------------------------- *---cas d'un objet de type TABLE ------------ *-------------------------------------------- call lirtab('PASAPAS',ITAP,0,iretou) if (iretou.gt.0) then call lirobj('MMODEL', IPMODE,1,iretou) if (ierr.ne.0) return CALL LIROBJ('MCHAML',IPCHA1,1,IRETOU) if (ierr.ne.0) return if (iretou.gt.0) call evrec6(itap,ipmode,ipcha1,mcha,nomco, &itype,iptu,ipevo) if (ierr.ne.0) return if (ipevo.gt.0) call ecrobj('EVOLUTION',ipevo) return endif IF (CTYP(1:5).EQ.'TABLE') THEN ITABL = 1 CALL LIRTAB ('RESULTAT_DYNE',ISTA,1,IRETOU) IF (IERR.NE.0) RETURN CALL LIRTAB ('BASE_MODALE',ISBM,0,IRETOU) IF (IRETOU.EQ.0) THEN CALL LIRTAB ('ENSEMBLE_DE_BASES',ISEB,1,IRETOU) IF (IERR.NE.0) RETURN IT = 0 56 CONTINUE IT = IT + 1 TYPRET = ' ' CALL ACCTAB (ISEB,'ENTIER',IT,X0,' ',L0,IRET0, & TYPRET,I1,X1,CHARRE,L1,ISBM) IF (ISBM.NE.0 .AND. TYPRET.EQ.'TABLE ') THEN CALL ACCTAB (ISBM,'MOT',I0,X0,'MODES',L0,IRET0, & 'TABLE',I1,X1,' ',L1,ISTB) CALL ACCTAB (ISTB,'MOT',I0,X0,'MAILLAGE',L0,IRET0, & 'MAILLAGE',I1,X1,' ',L1,IMAIL) CALL EXTR12(IMAIL,IRET,IRE12) IF (IRE12.EQ.0) GOTO 56 TYPRET = ' ' CALL ACCTAB (ISBM,'MOT',I0,X0,'PSEUDO_MODES',L0,IRET0, & TYPRET,I1,X1,CHARRE,L1,ITPS) IF (ITPS.NE.0 .AND. TYPRET.EQ.'TABLE ') KPSMO = 1 ELSE RETURN ENDIF ELSE CALL ACCTAB (ISBM,'MOT',I0,X0,'MODES',L0,IRET0, & 'TABLE',I1,X1,' ',L1,ISTB) TYPRET = ' ' CALL ACCTAB (ISBM,'MOT',I0,X0,'PSEUDO_MODES',L0,IRET0, & TYPRET,I1,X1,CHARRE,L1,ITPS) IF (ITPS.NE.0 .AND. TYPRET.EQ.'TABLE ') KPSMO = 1 ENDIF ENDIF *-------------------------------------------- *---cas d'un objet de type solution --------- *-------------------------------------------- IF (CTYP(1:8).EQ.'SOLUTION') THEN CALL LIROBJ('SOLUTION',KSOLU,1,IRETOU) IF(IERR.NE.0) RETURN ISOLU = 1 MSOLUT=KSOLU C---------------------------------------------------- C **** lecture de la base {l{mentaire C CALL LIRBAS(1,IBOBAS,IBOSEM) MSOBAS=IBOBAS MBASEM=IBOSEM IF(IERR.NE.0) RETURN ENDIF C---------------------------------------------------- C **** lecture du chargement pour les pseudo-modes C KCHAR = 0 CALL LIROBJ('CHARGEME',KCHAR,0,IRETOU) C---------------------------------------------------- C **** lecture des instants C IPX=0 ITOUS=0 ILX=0 CALL LIROBJ('LISTREEL',IPX,0,IRETOU) IF(IRETOU.EQ.0) CALL LIROBJ('LISTENTI',ILX,0,IRETOU) IF(IRETOU.EQ.0) ITOUS=1 * CALL EVNUMO(ITYPE,IRET,NOMCO,IBOO) NUMOO=IBOO IF(IERR.NE.0) RETURN *+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+ * cas d'un objet de type SOLUTION *+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+ IF (ISOLU.EQ.1) THEN SEGACT MSOLUT IF (MCHA.EQ.'CONT') MCHA = 'DEPL' MOTERR(1:8)=ITYSOL CALL CHRCHA(MCHA,MOTERR(1:8),ICHA,ISOLIT) IF(ICHA.EQ.0) THEN MOTERR(1:8)=ITYSOL MOTERR(9:12)=MCHA CALL ERREUR(235) * erreur dans le type du champ RETURN ENDIF MSOLEN=MSOLIS(ICHA) IF(MSOLEN.EQ.0) THEN MOTERR(1:8)=ITYSOL MOTERR(9:12)=MCHA CALL ERREUR(235) * ce type de champ est vide dans le MSOLUT RETURN ENDIF IF (ITYSOL.NE.'DYNAMIQU') THEN MOTERR(1:8)='SOLUTION' MOTERR(9:16)=ITYSOL CALL ERREUR(131) * option non disponible RETURN ENDIF IF (MSOLIT(ICHA).NE.2) THEN * la sortie porte sur des CHAMELEM * option non disponible CALL ERREUR(19 ) RETURN ENDIF IBOS=MSOLUT * v{rification des instants de sortie * dans IPX le LISTREEL @ mettre dans IPROGX * dans ILEX le LISTENTI qui contient les num{ros des champs CALL VERIDY(IBOS,IPX,ICHA,ITOUS,ILEX,ITYP1) IF(IERR.NE.0) RETURN MSOLUT=IBOS * IBOBAS=MSOBAS IBOO=NUMOO CALL EVOL2(IBOO,ILEX,IBOBAS,ICONT) IF(IERR.NE.0) RETURN MSOBAS=IBOBAS NUMOO=IBOO MLENTI=ILEX SEGSUP MLENTI * * prise en compte des pseudo-modes * SEGACT MSOBAS IMODE = IBSTRM(2) ILIAI = IBSTRM(4) KPSMO = IBSTRM(5) SEGDES MSOBAS IF (KPSMO.NE.0) THEN IF (ILIAI.NE.0) THEN MSOLUT = KSOLU SEGACT MSOLUT MOTERR(1:8) = ITYSOL MCHA = 'LIAI' CALL CHRCHA(MCHA,MOTERR(1:8),ICHA,ISOLIT) IF (ICHA.EQ.0) THEN MOTERR(1:8) = ITYSOL MOTERR(9:12) = MCHA CALL ERREUR(235) RETURN ENDIF MSOLEN = MSOLIS(ICHA) IF (MSOLEN.EQ.0) THEN MOTERR(1:8) = ITYSOL MOTERR(9:12) = MCHA CALL ERREUR(235) RETURN ENDIF SEGDES MSOLUT ITOU2 = 0 IBOS = KSOLU CALL VERIDY(IBOS,IPX,ICHA,ITOU2,ILEX2,ITYP1) IF (IERR.NE.0) RETURN ELSE ILEX2 = 0 ENDIF IBOO = NUMOO CALL PSEVO1(IMODE,KPSMO,IBOO,IPX,ILEX2,KCHAR,ICONT) NUMOO = IBOO ENDIF ENDIF *+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+ * cas d'un objet de type TABLE *+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+ IF (ITABL.EQ.1) THEN ICHA =0 LBO=0 * on prend la premi}re table (pas de temps 1) CALL ACCTAB (ISTA ,'ENTIER',1,X0,' ',L0,IRET0, & 'TABLE',I1,X1,' ',L1,IRET1) IF (ICONT.EQ.1) MCHA = 'DEPL' IF (ICONT.EQ.2) MCHA = 'DEPL' IBOBO=IRET1 CALL CHTCHA (MCHA,LCHALU,IBOBO,ICHA) IF (ICHA.EQ.0) THEN MOTERR(1:8)= MCHA(1:8) MOTERR(9:12)=MCHA CALL ERREUR(235) * erreur dans le type du champ RETURN ENDIF * v{rification des instants de sortie * dans IPX le LISTREEL @ mettre dans IPROGX * dans ILEX le LISTENTI qui contient les num{ros des champs CALL VERITA(ISTA,IPX,ICHA,ITOUS,ILEX,ITYP1) IF (IERR.NE.0) RETURN * CALL CHCHA2 (ISTB,ILEN1,ILEN2,ICONT) IF(IERR.NE.0) RETURN * IBOO=NUMOO CALL EVOL22 (IBOO,ILEX,ISTB,ILEN1,ILEN2) IF(IERR.NE.0) RETURN NUMOO=IBOO * * prise en compte de la rotation des corps rigides * IF (MCHA(1:4).EQ.'DEPL') THEN * On regarde si on a une base de corps rigide CALL VERRIG(ISTB,IROT,ICDG,ILEN1,ILEN2,IDEFO) IF (IROT.NE.0) THEN IBOO = NUMOO * Recombinaison des d�placements CALL EVORIG(IROT,ICDG,IBOO,ILEX,0,0,0,IDEFO) NUMOO = IBOO ENDIF ELSE IF (MCHA(1:4).EQ.'VITE') THEN * On regarde si on a une base de corps rigide CALL VERRIG(ISTB,IROT,ICDG,ILEN1,ILEN2,IDEFO) IF (IROT.NE.0) THEN * On r�cup�re les angles de rotation CALL CHTCHA('DEPL',4,IBOBO,ICHARO) IF (ICHARO.EQ.0) THEN MOTERR(1:8)=MCHA(1:8) MOTERR(9:12)=MCHA CALL ERREUR(235) RETURN ENDIF CALL VERITA(ISTA,IPX,ICHARO,ITOUS,ILEXRO,ITYP1) IBOO = NUMOO * On recombine les vitesses CALL EVORIG(IROT,ICDG,IBOO,ILEX,1,ILEXRO,0,IDEFO) NUMOO = IBOO ENDIF ELSE IF (MCHA(1:4).EQ.'ACCE') THEN * On regarde si on a une base de corps rigide CALL VERRIG(ISTB,IROT,ICDG,ILEN1,ILEN2,IDEFO) IF (IROT.NE.0) THEN * On r�cup�re les angles de rotation CALL CHTCHA('DEPL',4,IBOBO,ICHARO) IF (ICHARO.EQ.0) THEN MOTERR(1:8)=MCHA(1:8) MOTERR(9:12)=MCHA CALL ERREUR(235) RETURN ENDIF CALL VERITA(ISTA,IPX,ICHARO,ITOUS,ILEXRO,ITYP1) * On r�cup�re les vitesses de rotation CALL CHTCHA('VITE',4,IBOBO,ICHAVI) IF (ICHAVI.EQ.0) THEN MOTERR(1:8)=MCHA(1:8) MOTERR(9:12)=MCHA CALL ERREUR(235) RETURN ENDIF CALL VERITA(ISTA,IPX,ICHAVI,ITOUS,ILEXVI,ITYP1) IBOO = NUMOO * On recombine les acc�l�rations CALL EVORIG(IROT,ICDG,IBOO,ILEX,-1,ILEXRO, &ILEXVI,IDEFO) NUMOO = IBOO ENDIF ENDIF ENDIF ENDIF MLENTI=ILEN1 SEGSUP MLENTI MLENTI=ILEN2 SEGSUP MLENTI MLENTI=ILEX SEGSUP MLENTI * * prise en compte des pseudo-modes * IF (KPSMO.EQ.1) THEN IF (KCHAR.NE.0) THEN IBOO = NUMOO CALL PSEVRC(ICONT,ITPS,ISTB,IBOO,IPX,KCHAR) NUMOO = IBOO ELSE CALL ERREUR(430) ENDIF ENDIF ENDIF C ****************************************************************** C *** initialisation de MEVOLL C IF (ICONT.EQ.1) MCHA='CONT' IF (ICONT.EQ.2) MCHA='REAC' N=NUMO(/1) SEGINI MEVOLL ITYEVO='REEL' TI(1:72)=TITREE IEVTEX=TI DO 2080 I=1,N SEGINI KEVOLL TYPX='LISTREEL' TYPY='LISTREEL' IPROGX=IPX IPROGY=KLIST(I) NOMEVX=ITYP1 NOMEVY(1:4)=MCHA WRITE (NOMEVY(5:8),FMT='(I4)') NUMO(I) NOMEVY(9:12)=NUDDL(I) KEVTEX=TI NUMEVY='REEL' NUMEVX=ICOUL SEGDES KEVOLL IEVOLL(I)=KEVOLL 2080 CONTINUE SEGDES MEVOLL SEGSUP NUMOO CALL ECROBJ('EVOLUTIO',MEVOLL) * END