C TIRE SOURCE SP204843 26/02/03 21:15:40 12461 SUBROUTINE TIRE C======================================================================= C OPERATEUR TIRE C C OBJOL = TIRE MSOLUT TYPE ( ROBO ) ( INSTANTS ) ; C ---- ---- C ou C OBJOL = TIRE MCHARG FLOTTANT | ( 'TABL' ) ; C | ( MOT ) C C OBJOL : objet de type ......... C MSOLUT : objet SOLUTION C TYPE : MOT CLE:TYPE DE LA VARIABLE(DEPL,VITE,ACCE,LIAI, C POIN ..) C MCHARG : objet CHARGEMENT C MOT : nom du CHARGEMENT a instancier C FLOTTANT : temps pour lequel on desire le chargement. C C dans le cas d'un objet SOLUTION de type DYNAMIQUE issu d'une C resolution par PLEX : C 1- on peut obtenir les matrices ROTATION et leurs derivees C en posant TYPE = ROTA ( pour les TRANSLATIONS TYPE = ROTA ) C 2- si on desire effectuer une RECOmbinaison des VITESSES et C des ACCELERATIONS specifier le mot-clef ROBO apres TYPE C C INSTANTS: procedure facultative pour choisir les cas de sortie C MOT suivi d'une VALEUR C TEMP T : FLOTTANT temps a sortir C CAS ICAS : ENTIER cas a sortir C RANG IRG : ENTIER rang de l'objet a sortir C NUME INUME : ENTIER numero du mode a sortir C RIEN : on prend le dernier C C Dans le cas de l'objet chargement le mot clef TABL permet C de ranger les differents chargements instancies dans une C table pointant vers un CHPOINT (ou MCHAML) et d'indice C le nom du chargement. Si on donne un objet de type MOT C a l'operateur il calcule le champ instancie correspondant C uniquement aux chargements portant ce nom.Si aucun mot C n'est donne il instancie le chargement et renvoie un C objet de type CHPOINT ou MCHAML. C Pour des chargements mobiles l'operateur calcule le C champ effectif au temps voulu C-------------------------------------------------------------------- C CREATION : 16/10/85 C PROGRAMMEUR : FARVACQUE C PUIS CHARVET POUR INTRODUCTION DE L'OPTION ROBO ( NON C ENCORE TESTE SUR CRAY ) C APPELLE: LIRE LIRMOT CHRCHA ECRIRE TITMOD TYPFIL ERREUR(235 234 135) C LIRCHA LIRENT LIREE LIROBJ INTER1 MOCHPO DTCHPO ADCHPO PLACE C EXTENSION CHARGEMENT MOBILES 02/98 KICH C C======================================================================= IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCREEL -INC SMSOLUT -INC SMELEME -INC SMCHPOI -INC SMLCHPO -INC SMCHARG -INC SMLREEL -INC SMTABLE -INC SMEVOLL -INC SMLOBJE -INC SMCOORD PARAMETER (LMOOPT=4,LFREQ=6,LGDEP=2) CHARACTER*4 MOOPT(LMOOPT) CHARACTER*8 MTYP1,CHATY2 CHARACTER*4 MOGDEP(LGDEP) CHARACTER*4 MOROBO(1) CHARACTER*4 MOFREQ(LFREQ) CHARACTER *72 ITEX CHARACTER*8 TAPIND,TAPOBJ,TAPOB1,TAPOB2 CHARACTER*4 CHARIN,CHARRE, MTYPR LOGICAL LOGIN,LOGRE REAL*8 XVALIN,XVALRE CHARACTER CTYP*8,MCHA*4,MOT1*4 INTEGER LCHAR,MIN1,MAX1 DATA MOFREQ/'FREQ','MGEN','QX ','QY ','QZ ','POIN'/ DATA MOOPT/'TEMP','CAS ','RANG','NUME'/ DATA MOGDEP/'ROTA','TRAN'/ DATA MOROBO/'ROBO'/ DATA PRECI/1.E-3/ ITEX = ' ' ICHA2 = 0 ICHA3 = 0 IGDEP = 0 IVALIN= 0 XVALIN= 0.D0 LOGIN =.FALSE. IOBIN = 0 IVALRE= 0 XVALRE= 0 *---------------------------------------------------------------------- * CAS OU ON CHERCHE A TIRER UN CHARGEMENT *---------------------------------------------------------------------- *----- la nature du chpo de sortie est conditionnée par celle qui ----- *-------- sort de l'objet chargement si il y des incoherence ---------- *--------- adchpo et muchpo rendront une nature indeterminée ---------- IRETT = 0 CALL LIROBJ('CHARGEME',ICHAR,0,IRETOU) IF(IERR.NE.0) RETURN IF(IRETOU.EQ.0) GOTO 200 CALL LIRCHA(MOT1,0,LCHAR) IF (IERR.NE.0) RETURN IF (LCHAR.EQ.0) THEN MOT1 = ' ' ENDIF CALL LIRREE(XXX,1,IRETOU) IF (IERR.NE.0) RETURN T1 = XXX MCHARG=ICHAR CALL ACTOBJ('CHARGEME',MCHARG,1) C SEGACT MCHARG NCHAR=KCHARG(/1) *---------------------------------------------------------------------- *------- Cas ou on range le chargement instancie dans une TABLE ------ *---------------------------------------------------------------------- IF (MOT1.EQ.'TABL') THEN M = 0 SEGINI MTABLE ITA1 = MTABLE ** SEGDES MTABLE *-------------- boucle sur les chargements élémentaires --------------- DO 501 IC=1,NCHAR ICHARG=KCHARG(IC) C SEGACT ICHARG IPO1 = ICHPO1 IPO2 = ICHPO2 *--------- on ne considère que les objets de sous type force ----------- IF(CHANAT(IC).EQ.'DEPLACEM') THEN MOTERR(1:8)='CHARGEME' MOTERR(9:16)='DEPLACEM' CALL ERREUR(131) GOTO 599 ENDIF *------------ On ne considere que les chargements nommes --------------- IF (CHANOM(IC).EQ.' ') THEN CALL ERREUR(697) GOTO 599 ENDIF *--- cas des chargements elementaires CHPOINT (ou MCHAML) + EVOL ------- IF((CHATYP.EQ.'CHPOINT ').OR.(CHATYP.EQ.'MCHAML ')) THEN MLREEL=ICHPO2 C Cas particulier du chargement constant : on retourne le champ C sans aucune interpolation IF (ICHPO2.EQ.0) THEN IRET=ICHPO1 TAPOBJ=CHATYP C Cas general : interpolation dans l'evolution ELSE SEGACT MLREEL NF=PROG(/1) *------- Le temps %r1 sort de la table du %i1ème chargement ----------- C SP : on s'autorise a sortir de l'intervale de definition de l'evolution. C L'interpolation de l'amplitude est geree par INTER1. C T2 = T1 + ABS(T1*0.000001D0) C T3 = T1 - ABS(T1*0.000001D0) C IF(PROG(1).GT.T2.OR.PROG(NF).LT.T3) THEN C INTERR(1)=IC C REAERR(1)=T1 C CALL ERREUR(342) C GOTO 599 C ENDIF C------------- calcul du deplacement eventuel du champ ---------- IF (CHAMOB(IC).EQ.'TRAN'.OR.CHAMOB(IC).EQ.'ROTA'.OR. & CHAMOB(IC).EQ.'TRAJ') THEN MTYPR = CHAMOB(IC) IPOENT = IPO1 CHATY2 = CHATYP IPOENU = ICHPO4 IPOENV = ICHPO5 IPOENW = ICHPO6 IPOENX = ICHPO7 CALL TIDEP1(T1,IPOENT,CHATY2,MTYPR, $ IPOENU,IPOENV,IPOENW,IPOENX,IPOSOR) IF (IERR.NE.0) RETURN IPO1 = IPOSOR ENDIF C----- interpole la valeur de l'evolution FT1 au temps T1 ICHATX=ICHPO2 ICHAFX=ICHPO3 CALL INTER1(ICHATX,ICHAFX,T1,FT1) IRET = 0 C----- Cas du chargement de nom TRAJ : interpolation d'un point IF (CHANOM(IC).EQ.'TRAJ') THEN CALL IPLCUR(IPO1,FT1,IRET) IF (IERR.NE.0) RETURN TAPOBJ = 'POINT ' C----- Autres cas : multiplication du CHPOINT ou du MCHAML ----------- ELSE IOPERA = 2 IARGU = 2 I11 = 0 IF(CHATYP.EQ.'CHPOINT ') THEN TAPOBJ = 'CHPOINT ' CALL ACTOBJ('CHPOINT ',IPO1,1) CALL OPCHP1(IPO1,IOPERA,IARGU,I11,FT1,IRET,IRETOU) IF (IRETOU.EQ.0) THEN CALL ERREUR(26) RETURN ENDIF ELSE TAPOBJ = 'MCHAML ' CALL ACTOBJ('MCHAML ',IPO1,1) CALL OPCHE1(IPO1,IOPERA,IARGU,I11,FT1,IRET,IRETOU) IF (IRETOU.EQ.0) THEN CALL ERREUR(26) RETURN ENDIF ENDIF ENDIF ENDIF C C----- On met le resultat IRET dans la table : IF(IRET.EQ.0) GOTO 598 CHARIN = CHANOM(IC) IOBRE = IRET TAPIND = 'MOT ' CALL ECCTAB(ITA1,TAPIND,IVALIN,XVALIN,CHARIN,LOGIN,IOBIN, $ TAPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IOBRE) C---------------------------------------------------------------------- C Cas des chargements elementaires TABLE1-TABLE2 C---------------------------------------------------------------------- ELSEIF (CHATYP.EQ.'TABLE ') THEN IVALI1 = 0 IVALI2 = 1 MTAB1=IPO1 SEGACT MTAB1 JMA1=MTAB1.MLOTAB DO 505 JJ = 1,JMA1 XVALR1=MTAB1.RMTABV(IVALI1+1) TAPOB1=MTAB1.MTABTV(IVALI1+1) IF(JMA1.EQ.1) THEN XVALR2 = T1 ELSE XVALR2=MTAB1.RMTABV(IVALI2+1) TAPOB2=MTAB1.MTABTV(IVALI2+1) ENDIF IF(IVALI1.EQ.0) THEN IF (T1.LE.XVALR1) THEN DREL = 0.D0 GOTO 507 ENDIF ENDIF IF(IVALI2.EQ.(JMA1-1)) THEN IF (T1.GE.XVALR2) THEN DREL = 1.D0 GOTO 507 ENDIF ENDIF IF((XVALR1.LE.T1).AND.(T1.LE.XVALR2)) GOTO 506 5059 CONTINUE IVALI1 = IVALI1 + 1 IVALI2 = IVALI2 + 1 505 CONTINUE SEGDES MTAB1 *------- Le temps %r1 sort de la table du %i1ème chargement ---------- INTERR(1)=IC REAERR(1)=T1 CALL ERREUR(342) GOTO 599 506 CONTINUE *------------ la premiere table ne pointe pas vers des reels ---------- IF((TAPOB1.NE.TAPOB2).OR.(TAPOB1.NE.'FLOTTANT')) THEN CALL ERREUR(692) GOTO 599 ENDIF DREL = (T1 - XVALR1)/(XVALR2 - XVALR1) 507 CONTINUE TAPOB1 = ' ' TAPOB2 = ' ' TAPIND = 'ENTIER ' MTAB2=IPO2 SEGACT MTAB2 TAPOB1=MTAB2.MTABTV(IVALI1+1) TAPOB2=MTAB2.MTABTV(IVALI2+1) IOBR1=MTAB2.MTABIV(IVALI1+1) IOBR2=MTAB2.MTABIV(IVALI2+1) SEGDES MTAB2 *------ la deuxieme table ne pointe pas vers des champs de meme type ----- IF(TAPOB1.NE.TAPOB2) THEN CALL ERREUR(693) GOTO 599 ENDIF C------------- Cas du CHPOINT : IF(TAPOB1.EQ.'CHPOINT ') THEN CALL ECROBJ('CHPOINT ',IOBR1) CALL ECROBJ('CHPOINT ',IOBR2) CALL ECRREE(1.D0 - DREL) CALL ECRREE(DREL) CALL COLI CALL LIROBJ('CHPOINT ',IRET,1,IRETOU) IF(IRETOU.EQ.0) GOTO 599 C------------- calcul du deplacement eventuel du champ ---------- IF (CHAMOB(IC).EQ.'TRAN'.OR.CHAMOB(IC).EQ.'ROTA'.OR. & CHAMOB(IC).EQ.'TRAJ') THEN MTYPR = CHAMOB(IC) IPOENT = IRET CHATY2 = TAPOB1 IPOENU = ICHPO4 IPOENV = ICHPO5 IPOENW = ICHPO6 IPOENX = ICHPO7 CALL TIDEP1(T1,IPOENT,CHATY2,MTYPR, $ IPOENU,IPOENV,IPOENW,IPOENX,IPOSOR) IF (IERR.NE.0) RETURN IRET = IPOSOR ENDIF CHARIN = CHANOM(IC) TAPOBJ = 'CHPOINT ' IOBRE = IRET TAPIND = 'MOT ' CALL ECCTAB(ITA1,TAPIND,IVALIN,XVALIN,CHARIN, $ LOGIN,IOBIN,TAPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IOBRE) C------------- Cas du MCHAML : ELSEIF (TAPOB1.EQ.'MCHAML ') THEN IF (CHANOM(IC).EQ.'MATE') THEN IF (ABS(DREL-1.D0).LE.XZPREC) THEN IRET = IOBR2 ELSE IRET = IOBR1 ENDIF ELSE CALL ECROBJ('MCHAML ',IOBR1) CALL ECROBJ('MCHAML',IOBR2) CALL ECRREE(1.D0 - DREL) CALL ECRREE(DREL) CALL COLI CALL LIROBJ('MCHAML ',IRET,1,IRETOU) IF(IRETOU.EQ.0) GOTO 599 C------------- calcul du deplacement eventuel du champ ---------- IF (CHAMOB(IC).EQ.'TRAN'.OR.CHAMOB(IC).EQ.'ROTA'.OR. & CHAMOB(IC).EQ.'TRAJ') THEN MTYPR = CHAMOB(IC) IPOENT = IRET CHATY2 = TAPOB1 IPOENU = ICHPO4 IPOENV = ICHPO5 IPOENW = ICHPO6 IPOENX = ICHPO7 CALL TIDEP1(T1,IPOENT,CHATY2,MTYPR, $ IPOENU,IPOENV,IPOENW,IPOENX,IPOSOR) IF (IERR.NE.0) RETURN IRET = IPOSOR ENDIF ENDIF CHARIN = CHANOM(IC) TAPOBJ = 'MCHAML ' IOBRE = IRET TAPIND = 'MOT ' CALL ECCTAB(ITA1,TAPIND,IVALIN,XVALIN,CHARIN, $ LOGIN,IOBIN,TAPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IOBRE) C------------- Cas du MODELE : ELSEIF (TAPOB1.EQ.'MMODEL ') THEN IF (ABS(DREL-1.D0).LE.XZPREC) THEN IRET = IOBR2 ELSE IRET = IOBR1 ENDIF C------------- Cas du MAILLAGE : ELSEIF (TAPOB1.EQ.'MAILLAGE') THEN IF (ABS(DREL-1.D0).LE.XZPREC) THEN IRET = IOBR2 ELSE IRET = IOBR1 ENDIF C------------- Cas de la RIGIDITE : ELSEIF (TAPOB1.EQ.'RIGIDITE') THEN IF (ABS(DREL-1.D0).LE.XZPREC) THEN IRET = IOBR2 ELSE IRET = IOBR1 ENDIF C------------ Cas du POINT : ELSEIF (TAPOB1.EQ.'POINT ') THEN IF (ABS(DREL-1.D0).LE.XZPREC) THEN IRET = IOBR2 ELSE IF (ABS(DREL-0.D0).LE.XZPREC) THEN IRET = IOBR1 ELSE SEGACT,MCOORD*MOD C write(6,*) 'IOBR1, IOBR2,DREL=',IOBR1,IOBR2,DREL NBPTS = NBPTS+1 SEGADJ,MCOORD IDIMP1 = IDIM + 1 XP1 = XCOOR((IOBR1-1)*IDIMP1+1) YP1 = XCOOR((IOBR1-1)*IDIMP1+2) ZP1 = XCOOR((IOBR1-1)*IDIMP1+3) XP2 = XCOOR((IOBR2-1)*IDIMP1+1) YP2 = XCOOR((IOBR2-1)*IDIMP1+2) ZP2 = XCOOR((IOBR2-1)*IDIMP1+3) XCOOR((NBPTS-1)*IDIMP1+1) = DREL*XP2+(1.D0-DREL)*XP1 XCOOR((NBPTS-1)*IDIMP1+2) = DREL*YP2+(1.D0-DREL)*YP1 XCOOR((NBPTS-1)*IDIMP1+3) = DREL*ZP2+(1.D0-DREL)*ZP1 SEGDES,MCOORD IRET = NBPTS ENDIF *-- la 2e table ne pointe pas vers un CHPOINT, MCHAML, MMODLE ou un MAILLAGE ---- ELSE CALL ERREUR(694) GOTO 599 ENDIF C---------------------------------------------------------------------- C Cas des chargements elementaires LREE1-LOBJ1 C---------------------------------------------------------------------- ELSEIF (CHATYP.EQ.'LISTOBJE') THEN C---------- Recherche intervalle de temps contenant T1 IVALI1 = 0 IVALI2 = 1 MLREEL = IPO2 SEGACT, MLREEL MLOBJE = IPO1 SEGACT, MLOBJE JMA1 = PROG(/1) DO 405 JJ = 1,JMA1 XVALR1 = PROG(IVALI1+1) IF(JMA1.EQ.1) THEN XVALR2 = T1 ELSE XVALR2 = PROG(IVALI2+1) ENDIF IF(IVALI1.EQ.0) THEN IF (T1.LE.XVALR1) THEN DREL = 0.D0 GOTO 407 ENDIF ENDIF IF(IVALI2.EQ.(JMA1-1)) THEN IF (T1.GE.XVALR2) THEN DREL = 1.D0 GOTO 407 ENDIF ENDIF IF((XVALR1.LE.T1).AND.(T1.LE.XVALR2)) GOTO 406 IVALI1 = IVALI1 + 1 IVALI2 = IVALI2 + 1 405 CONTINUE C---------- SP : sans doute sans objet aujourd'hui (extrapolation permise) *---------- Le temps %r1 sort de la table du %i1eme chargement INTERR(1)=IC REAERR(1)=T1 CALL ERREUR(342) GOTO 599 C---------- On a trouve les piquets de temps encadrants T1 406 CONTINUE DREL = (T1 - XVALR1)/(XVALR2 - XVALR1) 407 CONTINUE IOBR1 = LISOBJ(IVALI1+1) IOBR2 = LISOBJ(IVALI2+1) MTYP1 = TYPOBJ C---------- Cas du CHPOINT : IF (MTYP1.EQ.'CHPOINT ') THEN CALL ECROBJ('CHPOINT ',IOBR1) CALL ECROBJ('CHPOINT ',IOBR2) CALL ECRREE(1.D0 - DREL) CALL ECRREE(DREL) CALL COLI CALL LIROBJ('CHPOINT ',IRET,1,IRETOU) IF (IRETOU.EQ.0) GOTO 599 C------------- calcul du deplacement eventuel du champ ---------- IF (CHAMOB(IC).EQ.'TRAN'.OR.CHAMOB(IC).EQ.'ROTA'.OR. & CHAMOB(IC).EQ.'TRAJ') THEN MTYPR = CHAMOB(IC) IPOENT = IRET CHATY2 = MTYP1 IPOENU = ICHPO4 IPOENV = ICHPO5 IPOENW = ICHPO6 IPOENX = ICHPO7 CALL TIDEP1(T1,IPOENT,CHATY2,MTYPR, $ IPOENU,IPOENV,IPOENW,IPOENX,IPOSOR) IF (IERR.NE.0) RETURN IRET = IPOSOR ENDIF CHARIN = CHANOM(IC) TAPOBJ = 'CHPOINT ' IOBRE = IRET TAPIND = 'MOT ' CALL ECCTAB(ITA1,TAPIND,IVALIN,XVALIN,CHARIN, $ LOGIN,IOBIN,TAPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IOBRE) C------------- Cas du MCHAML : ELSEIF (MTYP1.EQ.'MCHAML ') THEN IF (CHANOM(IC).EQ.'MATE') THEN IF (ABS(DREL-1.D0).LE.XZPREC) THEN IRET = IOBR2 ELSE IRET = IOBR1 ENDIF ELSE CALL ECROBJ('MCHAML ',IOBR1) CALL ECROBJ('MCHAML',IOBR2) CALL ECRREE(1.D0 - DREL) CALL ECRREE(DREL) CALL COLI CALL LIROBJ('MCHAML ',IRET,1,IRETOU) IF (IRETOU.EQ.0) GOTO 599 C------------- calcul du deplacement eventuel du champ ---------- IF (CHAMOB(IC).EQ.'TRAN'.OR.CHAMOB(IC).EQ.'ROTA'.OR. & CHAMOB(IC).EQ.'TRAJ') THEN MTYPR = CHAMOB(IC) IPOENT = IRET CHATY2 = MTYP1 IPOENU = ICHPO4 IPOENV = ICHPO5 IPOENW = ICHPO6 IPOENX = ICHPO7 CALL TIDEP1(T1,IPOENT,CHATY2,MTYPR, $ IPOENU,IPOENV,IPOENW,IPOENX,IPOSOR) IF (IERR.NE.0) RETURN IRET = IPOSOR ENDIF ENDIF CHARIN = CHANOM(IC) TAPOBJ = 'MCHAML ' IOBRE = IRET TAPIND = 'MOT ' CALL ECCTAB(ITA1,TAPIND,IVALIN,XVALIN,CHARIN, $ LOGIN,IOBIN,TAPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IOBRE) C------------- Cas du MODELE : ELSEIF (MTYP1.EQ.'MMODEL ') THEN IF (ABS(DREL-1.D0).LE.XZPREC) THEN IRET = IOBR2 ELSE IRET = IOBR1 ENDIF C------------- Cas du MAILLAGE : ELSEIF (MTYP1.EQ.'MAILLAGE') THEN IF (ABS(DREL-1.D0).LE.XZPREC) THEN IRET = IOBR2 ELSE IRET = IOBR1 ENDIF C------------- Cas de la RIGIDITE : ELSEIF (MTYP1.EQ.'RIGIDITE') THEN IF (ABS(DREL-1.D0).LE.XZPREC) THEN IRET = IOBR2 ELSE IRET = IOBR1 ENDIF C------------- Cas du POINT : ELSEIF (MTYP1.EQ.'POINT ') THEN IF (ABS(DREL-1.D0).LE.XZPREC) THEN IRET = IOBR2 ELSE IF (ABS(DREL-0.D0).LE.XZPREC) THEN IRET = IOBR1 ELSE SEGACT,MCOORD*MOD C write(6,*) 'IOBR1, IOBR2,DREL=',IOBR1,IOBR2,DREL NBPTS = NBPTS+1 SEGADJ,MCOORD IDIMP1 = IDIM + 1 XP1 = XCOOR((IOBR1-1)*IDIMP1+1) YP1 = XCOOR((IOBR1-1)*IDIMP1+2) ZP1 = XCOOR((IOBR1-1)*IDIMP1+3) XP2 = XCOOR((IOBR2-1)*IDIMP1+1) YP2 = XCOOR((IOBR2-1)*IDIMP1+2) ZP2 = XCOOR((IOBR2-1)*IDIMP1+3) XCOOR((NBPTS-1)*IDIMP1+1) = DREL*XP2+(1.D0-DREL)*XP1 XCOOR((NBPTS-1)*IDIMP1+2) = DREL*YP2+(1.D0-DREL)*YP1 XCOOR((NBPTS-1)*IDIMP1+3) = DREL*ZP2+(1.D0-DREL)*ZP1 SEGDES,MCOORD IRET = NBPTS ENDIF C--------- le LISTOBJE ne contient pas de CHPOINT, MCHAML, MMODLE ou MAILLAGE ELSE CALL ERREUR(694) GOTO 599 ENDIF ELSE C-------- Pas de type connu trouve CALL ERREUR(695) GOTO 599 ENDIF 501 CONTINUE CALL ECROBJ('TABLE ',ITA1) RETURN 598 IF(IC.NE.0) THEN DO 555 J = 1, IC IRETT = MTABIV(J) CALL DTCHPO(IRETT) 555 CONTINUE ENDIF 599 CONTINUE SEGSUP MTABLE RETURN ELSE *----------------------------------------------------------------------- *- cas ou on veut instancier un seul chargement elementaire de nom MOT - *------------------------------------------------------------------------- * cas ou on veut instancier tout le chargement et le ranger dans un seul champ *------------------------------------------------------------------------- ISU = 0 *-------------- boucle sur les chargements élémentaires --------------- DO 502 IC = 1, NCHAR IF (MOT1.NE.' ') THEN IF (mcharg.CHANOM(IC).NE.MOT1) GOTO 502 ENDIF *--------- on ne considère que les objets de sous type force ----------- IF(CHANAT(IC).EQ.'DEPLACEM') THEN MOTERR(1:8)='CHARGEME' MOTERR(9:16)='DEPLACEM' CALL ERREUR(131) GOTO 690 ENDIF ICHARG=KCHARG(IC) C SEGACT ICHARG IPO1 = ICHPO1 IPO2 = ICHPO2 *--- cas des chargements elementaires CHPOINT (ou MCHAML) + EVOL ------- IF((CHATYP.EQ.'CHPOINT ').OR.(CHATYP.EQ.'MCHAML ')) THEN C Cas particulier du chargement constant : on retourne le champ C sans aucune interpolation IF (ICHPO2.EQ.0) THEN IRET=ICHPO1 TAPOBJ=CHATYP C Cas general : interpolation dans l'evolution ELSE MLREEL=ICHPO2 SEGACT MLREEL NF=PROG(/1) *------- Le temps %r1 sort de la table du %i1ème chargement ------------- C SP : on s'autorise a sortir de l'intervale de definition de l'evolution. C L'interpolation de l'amplitude est geree par INTER1. C T2 = T1 + ABS(T1*0.000001D0) C T3 = T1 - ABS(T1*0.000001D0) C IF(PROG(1).GT.T2.OR.PROG(NF).LT.T3) THEN C INTERR(1)=IC C REAERR(1)=T1 C CALL ERREUR(342) C GOTO 690 C ENDIF C------------- calcul du deplacement eventuel du champ ---------- IF (CHAMOB(IC).EQ.'TRAN'.OR.CHAMOB(IC).EQ.'ROTA'.OR. & CHAMOB(IC).EQ.'TRAJ') THEN MTYPR = CHAMOB(IC) IPOENT = IPO1 CHATY2 = CHATYP IPOENU = ICHPO4 IPOENV = ICHPO5 IPOENW = ICHPO6 IPOENX = ICHPO7 CALL TIDEP1(T1,IPOENT,CHATY2,MTYPR, $ IPOENU,IPOENV,IPOENW,IPOENX,IPOSOR) IF(IERR.NE.0) RETURN IPO1 = IPOSOR ENDIF C----- interpole la valeur de l'evolution FT1 au temps T1 ICHATX=ICHPO2 ICHAFX=ICHPO3 CALL INTER1(ICHATX,ICHAFX,T1,FT1) C C----- Cas du chargement de nom TRAJ : IF (CHANOM(IC).EQ.'TRAJ') THEN IF (MOT1.EQ.'TRAJ'.OR.NCHAR.EQ.1) THEN C write(6,*) 'TIRE : chargement de nom TRAJ' CALL IPLCUR(IPO1,FT1,IPOIN1) IF (IERR.NE.0) RETURN CALL ECROBJ('POINT ',IPOIN1) RETURN ELSE C Si d'autres chargements : incompatible CALL ERREUR(695) GOTO 690 ENDIF ENDIF C----- Autres cas : realise la multiplication du CHPOINT ou du MCHAML ----------- IOPERA = 2 IARGU = 2 I11 = 0 IRET = 0 IF(CHATYP.EQ.'CHPOINT ') THEN CALL ACTOBJ('CHPOINT ',IPO1,1) CALL OPCHP1(IPO1,IOPERA,IARGU,I11,FT1,IRET,IRETOU) IF(IRETOU .EQ. 0)THEN CALL ERREUR(26) RETURN ENDIF ELSE CALL ACTOBJ('MCHAML ',IPO1,1) CALL OPCHE1(IPO1,IOPERA,IARGU,I11,FT1,IRET,IRETOU) IF(IRETOU .EQ. 0)THEN CALL ERREUR(26) RETURN ENDIF ENDIF ENDIF IF(IRET.EQ.0) GOTO 690 IF(ISU.EQ.0) THEN IRETT = IRET ISU = 1 CHATY2 = CHATYP ELSE *------------- Chargements elementaires incompatibles --------------- IF(CHATYP.NE.CHATY2) THEN CALL ERREUR(695) GOTO 690 ELSE IF(CHATYP.EQ.'CHPOINT ') THEN CALL FUCHPO(IRETT,IRET,IRETOU) C CALL DTCHPO(IRET) IF(IRETOU.EQ.0) THEN IF(IRETT.NE.0) THEN CALL DTCHPO(IRETT) ENDIF GOTO 690 ENDIF C CALL DTCHPO(IRETT) IRETT=IRETOU ELSEIF (CHATYP.EQ.'MCHAML ') THEN CALL ADCHEL(IRETT,IRET,IRETOU,1) IF (IERR.NE.0) RETURN IRETT=IRETOU ENDIF CHATY2 = CHATYP ENDIF ENDIF C---------------------------------------------------------------------- C Cas du chargement elementaire TABLE1-TABLE2 C---------------------------------------------------------------------- ELSEIF (CHATYP.EQ.'TABLE ') THEN IVALI1 = 0 IVALI2 = 1 mtab1=ipo1 segact mtab1 jma1=mtab1.mlotab DO 605 JJ = 1,JMA1 TAPOB1 =MTAB1. MTABTV(IVALI1+1) TAPOB2 =MTAB1. MTABTV(IVALI2+1) XVALR1=MTAB1.RMTABV(IVALI1+1) IF (JMA1.EQ.1) THEN XVALR2 = T1 ELSE XVALR2=MTAB1.RMTABV(IVALI2+1) ENDIF IF (IVALI1.EQ.0) THEN IF (T1.LE.XVALR1) THEN DREL = 0.D0 GOTO 607 ENDIF ENDIF IF (IVALI2.EQ.(JMA1-1)) THEN IF (T1.GE.XVALR2) THEN DREL = 1.D0 GOTO 607 ENDIF ENDIF IF((XVALR1.LE.T1).AND.(T1.LE.XVALR2)) GOTO 606 6059 CONTINUE IVALI1 = IVALI1 + 1 IVALI2 = IVALI2 + 1 605 CONTINUE *------- Le temps %r1 sort de la table du %i1ème chargement ------------- INTERR(1)=IC REAERR(1)=T1 CALL ERREUR(342) GOTO 690 606 CONTINUE *---------- la premiere table ne pointe pas vers des reels ---------- IF((TAPOB1.NE.TAPOB2).OR.(TAPOB1.NE.'FLOTTANT')) THEN CALL ERREUR(692) GOTO 690 ENDIF DREL = (T1 - XVALR1)/(XVALR2 - XVALR1) 607 CONTINUE SEGDES MTAB1 MTAB2=IPO2 SEGACT MTAB2 TAPOB1 =MTAB2. MTABTV(IVALI1+1) TAPOB2 =MTAB2. MTABTV(IVALI2+1) IOBR1 = MTAB2. MTABIV(IVALI1+1) IF (JMA1.EQ.1) THEN IRET = IOBR1 GOTO 668 ENDIF IOBR2=MTAB2. MTABIV(IVALI2+1) SEGDES MTAB2 *------ la deuxieme table ne pointe pas vers de champs de meme type ---- IF(TAPOB1.NE.TAPOB2) THEN write(6,*) ' ivali1 ' , ivali1 , ' ivali2 ' , ivali2 write(6,*) ' tapob1 ' , tapob1,' tapob2 ',tapob2 CALL ERREUR(693) GOTO 690 ENDIF IF(TAPOB1.EQ.'CHPOINT ') THEN CALL ECROBJ('CHPOINT ',IOBR1) CALL ECROBJ('CHPOINT ',IOBR2) CALL ECRREE(1.D0 - DREL) CALL ECRREE(DREL) CALL COLI CALL LIROBJ('CHPOINT ',IRET,1,IRETOU) IF(IRETOU.EQ.0) GOTO 690 C------------- calcul du deplacement eventuel du champ ---------- IF (CHAMOB(IC).EQ.'TRAN'.OR.CHAMOB(IC).EQ.'ROTA'.OR. & CHAMOB(IC).EQ.'TRAJ') THEN MTYPR = CHAMOB(IC) IPOENT = IRET CHATY2 = TAPOB1 IPOENU = ICHPO4 IPOENV = ICHPO5 IPOENW = ICHPO6 IPOENX = ICHPO7 CALL TIDEP1(T1,IPOENT,CHATY2,MTYPR, $ IPOENU,IPOENV,IPOENW,IPOENX,IPOSOR) IF(IERR.NE.0) RETURN IRET = IPOSOR ENDIF ELSEIF (TAPOB1.EQ.'MCHAML ') THEN IF (CHANOM(IC).EQ.'MATE') THEN IF (ABS(DREL-1.D0).LE.XZPREC) THEN IRET = IOBR2 ELSE IRET = IOBR1 ENDIF ELSE CALL ECROBJ('MCHAML ',IOBR1) CALL ECROBJ('MCHAML ',IOBR2) CALL ECRREE(1.D0 - DREL) CALL ECRREE(DREL) CALL COLI CALL LIROBJ('MCHAML ',IRET,1,IRETOU) IF(IRETOU.EQ.0) GOTO 690 C------------- calcul du deplacement eventuel du champ ---------- IF (CHAMOB(IC).EQ.'TRAN'.OR.CHAMOB(IC).EQ.'ROTA'.OR. & CHAMOB(IC).EQ.'TRAJ') THEN MTYPR = CHAMOB(IC) IPOENT = IRET CHATY2 = TAPOB1 IPOENU = ICHPO4 IPOENV = ICHPO5 IPOENW = ICHPO6 IPOENX = ICHPO7 CALL TIDEP1(T1,IPOENT,CHATY2,MTYPR, $ IPOENU,IPOENV,IPOENW,IPOENX,IPOSOR) IF(IERR.NE.0) RETURN IRET = IPOSOR ENDIF ENDIF C------------- Cas du MODELE : ELSEIF (TAPOB1.EQ.'MMODEL ') THEN IF (ABS(DREL-1.D0).LE.XZPREC) THEN IRET = IOBR2 ELSE IRET = IOBR1 ENDIF C------------- Cas du MAILLAGE : ELSEIF (TAPOB1.EQ.'MAILLAGE') THEN IF (ABS(DREL-1.D0).LE.XZPREC) THEN IRET = IOBR2 ELSE IRET = IOBR1 ENDIF C------------- Cas de la RIGIDITE : ELSEIF (TAPOB1.EQ.'RIGIDITE') THEN IF (ABS(DREL-1.D0).LE.XZPREC) THEN IRET = IOBR2 ELSE IRET = IOBR1 ENDIF C------------ Cas du POINT : ELSEIF (TAPOB1.EQ.'POINT ') THEN IF (ABS(DREL-1.D0).LE.XZPREC) THEN IRET = IOBR2 ELSE IF (ABS(DREL-0.D0).LE.XZPREC) THEN IRET = IOBR1 ELSE SEGACT,MCOORD*MOD C write(6,*) 'IOBR1, IOBR2,DREL=',IOBR1,IOBR2,DREL NBPTS = NBPTS+1 SEGADJ,MCOORD IDIMP1 = IDIM + 1 XP1 = XCOOR((IOBR1-1)*IDIMP1+1) YP1 = XCOOR((IOBR1-1)*IDIMP1+2) ZP1 = XCOOR((IOBR1-1)*IDIMP1+3) XP2 = XCOOR((IOBR2-1)*IDIMP1+1) YP2 = XCOOR((IOBR2-1)*IDIMP1+2) ZP2 = XCOOR((IOBR2-1)*IDIMP1+3) XCOOR((NBPTS-1)*IDIMP1+1) = DREL*XP2+(1.D0-DREL)*XP1 XCOOR((NBPTS-1)*IDIMP1+2) = DREL*YP2+(1.D0-DREL)*YP1 XCOOR((NBPTS-1)*IDIMP1+3) = DREL*ZP2+(1.D0-DREL)*ZP1 SEGDES,MCOORD IRET = NBPTS ENDIF *-- la 2e table ne pointe pas vers un CHPOINT, MCHAML, MMODLE ou un MAILLAGE ---- ELSE CALL ERREUR(694) GOTO 690 ENDIF 668 CONTINUE IF (ISU.EQ.0) THEN IRETT = IRET ISU = 1 CHATY2 = TAPOB1 ELSE *------------- Chargements elementaires incompatibles --------------- IF(TAPOB1.NE.CHATY2) THEN CALL ERREUR(695) GOTO 690 ELSE IF(TAPOB1.EQ.'CHPOINT ') THEN CALL FUCHPO(IRETT,IRET,IRETOU) C CALL DTCHPO(IRET) IF(IRETOU.EQ.0) THEN IF(IRETT.NE.0) THEN CALL DTCHPO(IRETT) ENDIF GOTO 690 ENDIF C CALL DTCHPO(IRETT) IRETT=IRETOU ELSEIF (TAPOB1.EQ.'MCHAML ') THEN CALL ADCHEL(IRETT,IRET,IRETOU,1) IF (IERR.NE.0) RETURN IRETT=IRETOU ELSEIF (TAPOB1.EQ.'MMODEL ') THEN CALL FUSMOD(IRETT,IRET,IRETOU) IF (IERR.NE.0) RETURN IRETT=IRETOU ELSEIF (TAPOB1.EQ.'MAILLAGE ') THEN CALL FUSE(IRETT,IRET,IRETOU,.false.) IF (IERR.NE.0) RETURN IRETT=IRETOU ELSEIF (TAPOB1.EQ.'RIGIDITE') THEN CALL FUSRIG(IRETT,IRET,IRETOU) IF (IERR.NE.0) RETURN IRETT=IRETOU ENDIF CHATY2 = TAPOB1 ENDIF ENDIF C---------------------------------------------------------------------- C Cas des chargements elementaires LREE1-LOBJ1 C---------------------------------------------------------------------- ELSEIF (CHATYP.EQ.'LISTOBJE') THEN C---------- Recherche intervalle de temps contenant T1 IVALI1 = 0 IVALI2 = 1 MLREEL = IPO2 SEGACT, MLREEL MLOBJE = IPO1 SEGACT, MLOBJE JMA1 = PROG(/1) DO 305 JJ = 1,JMA1 XVALR1 = PROG(IVALI1+1) IF(JMA1.EQ.1) THEN XVALR2 = T1 ELSE XVALR2 = PROG(IVALI2+1) ENDIF IF(IVALI1.EQ.0) THEN IF (T1.LE.XVALR1) THEN DREL = 0.D0 GOTO 307 ENDIF ENDIF IF(IVALI2.EQ.(JMA1-1)) THEN IF (T1.GE.XVALR2) THEN DREL = 1.D0 GOTO 307 ENDIF ENDIF IF((XVALR1.LE.T1).AND.(T1.LE.XVALR2)) GOTO 306 IVALI1 = IVALI1 + 1 IVALI2 = IVALI2 + 1 305 CONTINUE C---------- SP : sans doute sans objet aujourd'hui (extrapolation permise) *---------- Le temps %r1 sort de la table du %i1eme chargement INTERR(1)=IC REAERR(1)=T1 CALL ERREUR(342) GOTO 690 C---------- On a trouve les piquets de temps encadrants T1 306 CONTINUE DREL = (T1 - XVALR1)/(XVALR2 - XVALR1) C---------- Interpolation du chargement a T1 307 CONTINUE IOBR1 = LISOBJ(IVALI1+1) IF (JMA1.EQ.1) THEN IRET = IOBR1 GOTO 669 ENDIF IOBR2 = LISOBJ(IVALI2+1) MTYP1 = TYPOBJ C---------- Cas du CHPOINT : IF (MTYP1.EQ.'CHPOINT ') THEN CALL ECROBJ('CHPOINT ',IOBR1) CALL ECROBJ('CHPOINT ',IOBR2) CALL ECRREE(1.D0 - DREL) CALL ECRREE(DREL) CALL COLI CALL LIROBJ('CHPOINT ',IRET,1,IRETOU) IF (IRETOU.EQ.0) GOTO 690 C------------- calcul du deplacement eventuel du champ ---------- IF (CHAMOB(IC).EQ.'TRAN'.OR.CHAMOB(IC).EQ.'ROTA'.OR. & CHAMOB(IC).EQ.'TRAJ') THEN MTYPR = CHAMOB(IC) IPOENT = IRET CHATY2 = MTYP1 IPOENU = ICHPO4 IPOENV = ICHPO5 IPOENW = ICHPO6 IPOENX = ICHPO7 CALL TIDEP1(T1,IPOENT,CHATY2,MTYPR, $ IPOENU,IPOENV,IPOENW,IPOENX,IPOSOR) IF (IERR.NE.0) RETURN IRET = IPOSOR ENDIF C------------- Cas du MCHAML : ELSEIF (MTYP1.EQ.'MCHAML ') THEN IF (CHANOM(IC).EQ.'MATE') THEN IF (ABS(DREL-1.D0).LE.XZPREC) THEN IRET = IOBR2 ELSE IRET = IOBR1 ENDIF ELSE CALL ECROBJ('MCHAML ',IOBR1) CALL ECROBJ('MCHAML',IOBR2) CALL ECRREE(1.D0 - DREL) CALL ECRREE(DREL) CALL COLI CALL LIROBJ('MCHAML ',IRET,1,IRETOU) IF (IRETOU.EQ.0) GOTO 690 C------------- calcul du deplacement eventuel du champ ---------- IF (CHAMOB(IC).EQ.'TRAN'.OR.CHAMOB(IC).EQ.'ROTA'.OR. & CHAMOB(IC).EQ.'TRAJ') THEN MTYPR = CHAMOB(IC) IPOENT = IRET CHATY2 = MTYP1 IPOENU = ICHPO4 IPOENV = ICHPO5 IPOENW = ICHPO6 IPOENX = ICHPO7 CALL TIDEP1(T1,IPOENT,CHATY2,MTYPR, $ IPOENU,IPOENV,IPOENW,IPOENX,IPOSOR) IF (IERR.NE.0) RETURN IRET = IPOSOR ENDIF ENDIF C------------- Cas du MODELE : ELSEIF (MTYP1.EQ.'MMODEL ') THEN IF (ABS(DREL-1.D0).LE.XZPREC) THEN IRET = IOBR2 ELSE IRET = IOBR1 ENDIF C------------- Cas du MAILLAGE : ELSEIF (MTYP1.EQ.'MAILLAGE') THEN IF (ABS(DREL-1.D0).LE.XZPREC) THEN IRET = IOBR2 ELSE IRET = IOBR1 ENDIF C------------- Cas de la RIGIDITE : ELSEIF (MTYP1.EQ.'RIGIDITE') THEN IF (ABS(DREL-1.D0).LE.XZPREC) THEN IRET = IOBR2 ELSE IRET = IOBR1 ENDIF C------------- Cas du POINT : ELSEIF (MTYP1.EQ.'POINT ') THEN IF (ABS(DREL-1.D0).LE.XZPREC) THEN IRET = IOBR2 ELSE IF (ABS(DREL-0.D0).LE.XZPREC) THEN IRET = IOBR1 ELSE SEGACT,MCOORD*MOD C write(6,*) 'NBPTS,IOBR1, IOBR2,DREL=',NBPTS,IOBR1,IOBR2,DREL NBPTS = NBPTS+1 SEGADJ,MCOORD IDIMP1 = IDIM + 1 XP1 = XCOOR((IOBR1-1)*IDIMP1+1) YP1 = XCOOR((IOBR1-1)*IDIMP1+2) ZP1 = XCOOR((IOBR1-1)*IDIMP1+3) XP2 = XCOOR((IOBR2-1)*IDIMP1+1) YP2 = XCOOR((IOBR2-1)*IDIMP1+2) ZP2 = XCOOR((IOBR2-1)*IDIMP1+3) XCOOR((NBPTS-1)*IDIMP1+1) = DREL*XP2+(1.D0-DREL)*XP1 XCOOR((NBPTS-1)*IDIMP1+2) = DREL*YP2+(1.D0-DREL)*YP1 XCOOR((NBPTS-1)*IDIMP1+3) = DREL*ZP2+(1.D0-DREL)*ZP1 SEGDES,MCOORD IRET = NBPTS ENDIF C--------- le LISTOBJE ne contient pas de CHPOINT, MCHAML, MMODLE ou MAILLAGE ELSE CALL ERREUR(694) GOTO 690 ENDIF 669 CONTINUE IF (ISU.EQ.0) THEN IRETT = IRET ISU = 1 CHATY2 = MTYP1 ELSE *------------- Chargements elementaires incompatibles --------------- IF(MTYP1.NE.CHATY2) THEN CALL ERREUR(695) GOTO 690 ELSE IF(MTYP1.EQ.'CHPOINT ') THEN CALL FUCHPO(IRETT,IRET,IRETOU) IF(IRETOU.EQ.0) THEN IF(IRETT.NE.0) THEN CALL DTCHPO(IRETT) ENDIF GOTO 690 ENDIF C CALL DTCHPO(IRETT) IRETT=IRETOU ELSEIF (MTYP1.EQ.'MCHAML ') THEN CALL ADCHEL(IRETT,IRET,IRETOU,1) IF (IERR.NE.0) RETURN IRETT=IRETOU ELSEIF (MTYP1.EQ.'MMODEL ') THEN CALL FUSMOD(IRETT,IRET,IRETOU) IF (IERR.NE.0) RETURN IRETT=IRETOU ELSEIF (MTYP1.EQ.'MAILLAGE ') THEN CALL FUSE(IRETT,IRET,IRETOU,.false.) IF (IERR.NE.0) RETURN IRETT=IRETOU ELSEIF (MTYP1.EQ.'RIGIDITE') THEN CALL FUSRIG(IRETT,IRET,IRETOU) IF (IERR.NE.0) RETURN IRETT=IRETOU ENDIF CHATY2 = MTYP1 ENDIF ENDIF ELSE C---------- Fin ELSEIF sur CHATYP : pas de type connu trouve CALL ERREUR(695) GOTO 690 ENDIF 502 CONTINUE IF(IRETT.EQ.0) THEN IF (MOT1.NE.' ') THEN MOTERR(1:4) = MOT1 CALL ERREUR(685) ELSE CALL ERREUR(696) ENDIF RETURN ENDIF IF (CHATY2.EQ.'CHPOINT ') THEN CALL ACTOBJ('CHPOINT ',IRETT,1) CALL ECROBJ('CHPOINT ',IRETT) ELSEIF (CHATY2.EQ.'MCHAML ') THEN CALL ACTOBJ('MCHAML ',IRETT,1) CALL ECROBJ('MCHAML ',IRETT) ELSEIF (CHATY2.EQ.'MMODEL ') THEN CALL ACTOBJ('MMODEL ',IRETT,1) CALL ECROBJ('MMODEL ',IRETT) ELSEIF (CHATY2.EQ.'MAILLAGE') THEN CALL ACTOBJ('MAILLAGE',IRETT,1) CALL ECROBJ('MAILLAGE',IRETT) ELSEIF (CHATY2.EQ.'RIGIDITE') THEN CALL ACTOBJ('RIGIDITE',IRETT,1) CALL ECROBJ('RIGIDITE',IRETT) ELSEIF (CHATY2.EQ.'POINT ') THEN CALL ECROBJ('POINT ',IRETT) ELSE CALL ERREUR(694) ENDIF RETURN 690 CONTINUE RETURN ENDIF C---------------------------- C CAS DE L'OBJET SOLUTION C----------------------------- 200 CONTINUE ISOLIT=0 CALL LIRCHA(MCHA,0,IRETOU) IF(IRETOU.EQ.0) GO TO 300 C CALL LIROBJ('SOLUTION ',KSOLU,1,IRETOU) IF(IERR.NE.0) GOTO 5000 MSOLUT=KSOLU C C *** ON VA CHERCHER LE CHAMP DE TYPE MCHA DANS LE MSOLUT SEGACT MSOLUT C C *** LECTURE DE FN,MN,QX,QY OU QZ ? CALL PLACE(MOFREQ,LFREQ,IPLAC,MCHA) IF(IPLAC.NE.0) THEN ICHA=4 GOTO 50 ENDIF C *** OPTION GRAND DEPLACEMENT ? CALL PLACE (MOGDEP,LGDEP,IGDEP,MCHA) IF(IGDEP .NE. 0) THEN ICHA = 10 + IGDEP GOTO 50 ENDIF C *** LECTURE DES DEPLACEMENTS,DES CONTRAINTES ... MOTERR(1:8)=ITYSOL CALL CHRCHA(MCHA,MOTERR(1:8),ICHA,ISOLIT) IF(ICHA.EQ.0) THEN MOTERR(1:8)='SOLUTION' MOTERR(9:26)=ITYSOL MOTERR(30:38)=MCHA CALL ERREUR(235) C ERREUR DANS LE TYPE DE CHAMP GOTO 5000 ENDIF C TYPE = VITE + ROBO C IF(ICHA.EQ.8) THEN CALL LIRMOT ( MOROBO,1,IROBO,0 ) IF( IROBO.NE.0 ) THEN ICHA2 = ICHA ICHA = 5 ENDIF ENDIF C TYPE = ACCE + ROBO C IF(ICHA.EQ.9) THEN CALL LIRMOT ( MOROBO,1,IROBO,0 ) IF( IROBO.NE.0 ) THEN ICHA3 = ICHA ICHA2 = ICHA - 1 ICHA = 5 ENDIF ENDIF C============================= 50 MSOLEN=MSOLIS(ICHA) IF(MSOLEN.EQ.0) THEN MOTERR(1:8)='SOLUTION' MOTERR(9:26)=ITYSOL MOTERR(30:38)=MCHA CALL ERREUR(235) GOTO 5000 ENDIF ISOLIT=MSOLIT(ICHA) SEGACT MSOLEN LTE=ISOLEN(/1) C C **** CALCUL DE IRG LE RANG DE L'OBJET CHERCHE C IRG=0 CALL LIRMOT(MOOPT,LMOOPT,IMOT,0) C ------------------------------ON PREND LA DERNIERE VALEUR--------- IF(IMOT.NE.0) GOTO 700 IRG=LTE GOTO 152 C C --------------------------------- RECHERCHE D'UN TEMPS----------- 700 IF(IMOT.NE.1)GOTO 701 MSOLRE=MSOLIS(1) IF(MSOLRE.EQ.0) GOTO 140 SEGACT MSOLRE CALL LIRREE (XXX,1,IRETOU) IF(IERR.NE.0) GOTO 5000 T1=XXX IF(T1.EQ.0.) THEN IF(SOLRE(1).EQ.0.) THEN IRG=1 SEGDES MSOLRE GOTO 152 ENDIF GOTO 140 ENDIF DO 153 J=1,LTE T2=SOLRE(J) TR=ABS((T2-T1)/T1) IF(TR.LT.PRECI) THEN IRG=J SEGDES MSOLRE GOTO 152 ENDIF IF(T2.GT.T1) GOTO 140 153 CONTINUE 140 CONTINUE SEGDES MSOLRE MOTERR(9:16)='FLOTTANT' GOTO 145 C -------------------------------------RECHERCHE D'UN CAS----------- 701 CONTINUE IF(IMOT.NE.2)GOTO 702 MSOLE1=MSOLIS(2) IF(MSOLE1.EQ.0) GOTO 141 SEGACT MSOLE1 CALL LIRENT(L1,1,IRETOU) IF(IERR.NE.0) GOTO 5000 DO 154 J=1,LTE IF(L1.EQ.MSOLE1.ISOLEN(J))THEN IRG=J SEGDES MSOLE1 GOTO 152 ENDIF 154 CONTINUE 141 CONTINUE SEGDES MSOLE1 MOTERR(9:16)='ENTIER ' GOTO 145 C -------------------------------------- RECHERCHE D'UN RANG----------- 702 IF(IMOT.NE.3) GOTO 703 CALL LIRENT(IRG,1,IRETOU) IF(IERR.NE.0) GOTO 5000 IF(IRG.GT.LTE.OR.IRG.LT.1) THEN MOTERR(1:8) = ITYSOL CALL ERREUR(203) GOTO 5000 ENDIF GOTO 152 C ---------------------------------------RECHERCHE D UN NUMERO DE MODE-- 703 IF(IMOT.NE.4) GOTO 5000 CALL LIRENT(INUME,1,IRETOU) IF(IERR.NE.0) GOTO 5000 IRG=INUME C C C C C GOTO 152 C --------------------------------ERREUR------------------------- 145 CONTINUE MOTERR(1:8)='SOLUTION' CALL ERREUR(135) GOTO 5000 C ------------------------------------------------------------------ 152 CONTINUE IRET = ISOLEN(IRG) SEGDES MSOLEN IF ( IRET.EQ.0 ) THEN MOTERR(1:8) = ITYSOL MOTERR(9:12)= MCHA INTERR(1) = IRG CALL ERREUR(234) GOTO 5000 ENDIF C TYPE = ACCE + ROBO C VITE IF ( ICHA2.NE.0 ) THEN MSOLEN = MSOLIS(ICHA2) IF(MSOLEN.EQ.0) THEN MOTERR(1:8)='SOLUTION' MOTERR(9:26)=ITYSOL MOTERR(30:38)=MCHA CALL ERREUR(235) GOTO 5000 ENDIF ISOLI2 = MSOLIT(ICHA2) IF ( ISOLI2.NE.ISOLIT ) GOTO 5000 SEGACT MSOLEN IRET2 = ISOLEN(IRG) SEGDES MSOLEN IF ( IRET2.EQ.0 ) THEN MOTERR(1:8) = ITYSOL MOTERR(9:12) = MCHA INTERR(1) = IRG CALL ERREUR(234) GOTO 5000 ENDIF ENDIF C TYPE = ACCE + ROBO C IF ( ICHA3.NE.0 ) THEN MSOLEN = MSOLIS(ICHA3) IF(MSOLEN.EQ.0) THEN MOTERR(1:8)='SOLUTION' MOTERR(9:26)=ITYSOL MOTERR(30:38)=MCHA CALL ERREUR(235) GOTO 5000 ENDIF ISOLI3 = MSOLIT(ICHA3) IF ( ISOLI3.NE.ISOLIT ) GOTO 5000 SEGACT MSOLEN IRET3 = ISOLEN(IRG) SEGDES MSOLEN IF ( IRET3.EQ.0 ) THEN MOTERR(1:8) = ITYSOL MOTERR(9:12) = MCHA INTERR(1) = IRG CALL ERREUR(234) GOTO 5000 ENDIF ENDIF C C **** FREQUENCE* /MGEN /QX /QY /QZ / POIN ************************** C POIN IF ( IPLAC.EQ.6) THEN IF(ITYSOL.NE.'DYNAMIQU') THEN MELEME = MSOLIS(3) SEGACT MELEME IPOINN = NUM(1,IRG) * CALL ECRENT(IPOINN) SEGDES MELEME CALL ECROBJ ('POINT',IPOINN) GOTO 5000 ELSE MOTERR(1:8)='SOLUTION' MOTERR(9:12) = ITYSOL INTERR(1) = IRG CALL ERREUR(131) GOTO 5000 ENDIF ENDIF IF ( ICHA.EQ.4 ) THEN MMODE = IRET SEGACT MMODE RET = FMMODD(IPLAC) SEGDES MMODE CALL ECRREE(RET) GOTO 5000 ENDIF C C *** LE MSOLUT EST UN MODE --------------------------------------- C IF ( ITYSOL.NE.'MODE ') GOTO 800 MSOLEN = MSOLIS(4) SEGACT MSOLEN MMODE = ISOLEN(IRG) SEGDES MSOLEN CALL TITMOD(MMODE,ITEX) GOTO 899 C 800 CONTINUE IF ( IMOT.NE.1 ) GOTO 801 WRITE(ITEX(1:24),FMT='(A4,8X,1PE12.5)') MCHA,T1 ITEX(5:12) = ' T=' GOTO 899 801 CONTINUE 899 CONTINUE C C *** LA SORTIE PORTE SUR DES CHPOINTS--------------------------- C IF ( ISOLIT.NE.2 ) GOTO 600 IF ( ICHA2.EQ.0 ) THEN IF (ITEX.NE.' ') THEN MCHPOI = IRET SEGACT MCHPOI*MOD MOCHDE = ITEX ENDIF GOTO 699 ENDIF C TYPE = VITE + ROBO C IF ( ICHA3.EQ.0 ) THEN N1 = 2 SEGINI MLCHPO ICHPOI(1) = IRET ICHPOI(2) = IRET2 IF (ITEX.NE.' ') THEN MCHPOI = IRET SEGACT MCHPOI*MOD MOCHDE = ITEX ENDIF ISOLIT = 34 IRET = MLCHPO GOTO 699 ENDIF C TYPE = ACCE + ROBO C N1 = 3 SEGINI MLCHPO ICHPOI(1) = IRET ICHPOI(2) = IRET2 ICHPOI(3) = IRET3 IF (ITEX.NE.' ') THEN MCHPOI = IRET SEGACT MCHPOI*MOD MOCHDE = ITEX ENDIF ISOLIT = 34 IRET = MLCHPO GOTO 699 C 600 CONTINUE IF ( ISOLIT.NE.5 ) GOTO 601 WRITE(IOIMP,*) 'TIRE :CAS ISOLIT=5 N EST PLUS BRANCHE' C 601 CONTINUE 699 CONTINUE CTYP = ' ' CALL TYPFIL (CTYP,ISOLIT) CALL ACTOBJ (CTYP,IRET,1) CALL ECROBJ (CTYP,IRET) 5000 CONTINUE RETURN C C PAS D OPERANDE CORRECTE TROUVE C 300 CALL QUETYP(MOTERR(1:8),0,IRETOU) IF(IRETOU.NE.0) THEN CALL ERREUR (39) ELSE CALL ERREUR(533) ENDIF RETURN END