C TIRE SOURCE SERRE 12/03/29 21:15:05 7333 SUBROUTINE TIRE IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) 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======================================================================= -INC CCOPTIO -INC SMCOORD -INC SMSOLUT -INC SMELEME -INC SMCHPOI -INC SMLCHPO -INC SMCHARG -INC SMLREEL -INC SMTABLE -INC SMEVOLL SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) DIMENSION X(3),Y(4) COMMON /CTOURN/XPT1,YPT1,ZPT1,XV1,YV1,ZV1,XV2,YV2,ZV2,XVEC,YVEC, # ZVEC,ANGLE,ICLE PARAMETER (LMOOPT=4) CHARACTER*4 MOOPT(LMOOPT) CHARACTER*8 MTYPI,CHATY2 CHARACTER*4 MOGDEP(2), MTYPR CHARACTER*4 MOROBO(1) CHARACTER*4 MOFREQ(6) CHARACTER *72 ITEX CHARACTER*8 TAPIND,TAPOBJ,TAPOB1,TAPOB2 CHARACTER*4 CHARIN,CHARRE 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(1)/'ROBO'/ DATA PRECI/1.E-3/ ITEX = ' ' IUN = 1 ICHA2 = 0 ICHA3 = 0 IGDEP = 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 ---------- LFREQ=5 LFREQ=6 LGDEP = 2 IRETT = 0 CALL LIROBJ('CHARGEME',ICHAR,0,IRETOU) IF(IERR.NE.0) RETURN IF(IRETOU.EQ.0) GO TO 200 CALL LIRCHA(MOT1,0,LCHAR) IF (LCHAR.EQ.0) THEN MOT1 = ' ' ENDIF *---------------------------------------------------------------------- *------- Cas ou on range le chargement instancie dans une TABLE ------ *---------------------------------------------------------------------- IF (MOT1.EQ.'TABL') THEN CALL LIRREE(XXX,1,IRETOU) IF(IERR.NE.0) RETURN T1=XXX MCHARG=ICHAR SEGACT MCHARG NCHAR=KCHARG(/1) M = 0 SEGINI MTABLE ITA1 = MTABLE SEGDES MTABLE *-------------- boucle sur les chargements élémentaires --------------- DO 501 IC=1,NCHAR ICHARG=KCHARG(IC) 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) GO TO 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 SEGACT MLREEL NF=PROG(/1) *------- Le temps %r1 sort de la table du %i1ème chargement ----------- T2 = T1 + ABS(T1*0.000001D0) T3 = T1 - ABS(T1*0.000001D0) IF(PROG(1).GT.T2.OR.PROG(NF).LT.T3) THEN INTERR(1)=IC REAERR(1)=T1 CALL ERREUR(342) SEGDES MLREEL GO TO 599 ENDIF SEGDES MLREEL 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----- realise la multiplication du CHPOINT ou du MCHAML ----------- ICHATX=ICHPO2 ICHAFX=ICHPO3 CALL INTER1(ICHATX,ICHAFX,T1,FT1) IF(CHATYP.EQ.'CHPOINT ') THEN TAPOBJ = 'CHPOINT ' CALL MUCHPO(IPO1,FT1,IRET,1) ELSE TAPOBJ = 'MCHAML ' CALL MUCHEL(IPO1,FT1,IRET,1) ENDIF IF(IRET.EQ.0) GO TO 598 CHARIN = CHANOM(IC) IOBRE = IRET TAPIND = 'MOT ' CALL ECCTAB(ITA1,TAPIND,IVALIN,XVALIN,CHARIN, $ LOGIN,IOBIN,TAPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IOBRE) *----------- cas des chargements elementaires TABLE1 - TABLE2 ---------- ELSE IVALI1 = 0 IVALI2 = 1 mtab1=ipo1 segact mtab1 * CALL ECROBJ('TABLE ',ICHPO1) * CALL DIMENS * CALL LIRENT(JMA1,1,IRETOU) jma1=mtab1.mlotab * IF (IRETOU.EQ.0) GOTO 599 DO 505 JJ = 1,JMA1 * TAPOB1 = ' ' * TAPOB2 = ' ' * TAPIND = 'ENTIER ' * CALL ACCTAB(IPO1,TAPIND,IVALI1,XVALIN,CHARIN, * $ LOGIN,IOBIN,TAPOB1,IVALRE,XVALR1,CHARRE,LOGRE,IOBRE) * IF(TAPOB1.eq.' ') go to 5059 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) * CALL ACCTAB(IPO1,TAPIND,IVALI2,XVALIN,CHARIN, * $ LOGIN,IOBIN,TAPOB2,IVALRE,XVALR2,CHARRE,LOGRE,IOBRE) ENDIF IF (IVALI1.EQ.0) THEN IF (T1.LE.XVALR1) THEN DREL = 0.D0 GOTO 507 ENDIF ENDIF IF (IVALI2.EQ.JMA1) 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) GO TO 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) * CALL ACCTAB(IPO2,TAPIND,IVALI1,XVALIN,CHARIN, * $ LOGIN,IOBIN,TAPOB1,IVALRE,XVALRE,CHARRE,LOGRE,IOBR1) * CALL ACCTAB(IPO2,TAPIND,IVALI2,XVALIN,CHARIN, * $ LOGIN,IOBIN,TAPOB2,IVALRE,XVALRE,CHARRE,LOGRE,IOBR2) segdes mtab2 *------ la deuxieme table ne pointe pas vers des champs de meme type ----- IF(TAPOB1.NE.TAPOB2) THEN c write(6,*) ' passage 1' c write(6,*) ' ivali1 ' , ivali1 , ' ivali2 ' , ivali2 c write(6,*) ' tapob1 ' ,tapob1,' tapob2 ',tapob2 CALL ERREUR(693) GOTO 599 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 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 = 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 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) ELSE IF (TAPOB1.EQ.'MCHAML ') THEN 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 = 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 IRET = IPOSOR 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) *-------- la deuxieme table ne pointe pas vers un CHPOINT ou MCHAML ---- ELSE CALL ERREUR(694) GOTO 599 ENDIF C C ------- pas d'autre maniere de formatter les chargements ----- ENDIF SEGDES ICHARG 501 CONTINUE SEGDES MCHARG 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 SEGDES ICHARG SEGDES MCHARG 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 *------------------------------------------------------------------------- CALL LIRREE(XXX,1,IRETOU) IF(IERR.NE.0) RETURN T1=XXX MCHARG=ICHAR SEGACT MCHARG NCHAR=KCHARG(/1) ISU = 0 *-------------- boucle sur les chargements élémentaires --------------- DO 502 IC=1,NCHAR IF(MOT1.NE.' ') THEN IF(CHANOM(IC).NE.MOT1) GOTO 502 ENDIF ICHARG=KCHARG(IC) 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) GO TO 690 ENDIF *--- cas des chargements elementaires CHPOINT (ou MCHAML) + EVOL ------- IF((CHATYP.EQ.'CHPOINT ').OR.(CHATYP.EQ.'MCHAML ')) THEN MLREEL=ICHPO2 SEGACT MLREEL NF=PROG(/1) *------- Le temps %r1 sort de la table du %i1ème chargement ------------- T2 = T1 + ABS(T1*0.000001D0) T3 = T1 - ABS(T1*0.000001D0) IF(PROG(1).GT.T2.OR.PROG(NF).LT.T3) THEN INTERR(1)=IC REAERR(1)=T1 CALL ERREUR(342) SEGDES MLREEL GO TO 690 ENDIF SEGDES MLREEL 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 ICHATX=ICHPO2 ICHAFX=ICHPO3 CALL INTER1(ICHATX,ICHAFX,T1,FT1) IF(CHATYP.EQ.'CHPOINT ') THEN CALL MUCHPO(IPO1,FT1,IRET,1) ELSE CALL MUCHEL(IPO1,FT1,IRET,1) ENDIF IF(IRET.EQ.0) GO TO 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) CALL DTCHPO(IRET) IF(IRETOU.EQ.0) THEN IF(IRETT.NE.0) THEN CALL DTCHPO(IRETT) ENDIF GOTO 690 ENDIF CALL DTCHPO(IRETT) IRETT=IRETOU ELSE IF (CHATYP.EQ.'MCHAML ') THEN CALL ADCHEL(IRETT,IRET,IRETOU,1) CALL DTCHEL(IRET) IF(IRETOU.EQ.0) THEN IF(IRETT.NE.0) THEN CALL DTCHEL(IRETT) ENDIF GOTO 690 ENDIF CALL DTCHEL(IRETT) IRETT=IRETOU ENDIF CHATY2 = CHATYP ENDIF ENDIF *---------- cas du chargement elementaire TABLE1-TABLE2 ------------- ELSE IVALI1 = 0 IVALI2 = 1 mtab1=ipo1 segact mtab1 jma1=mtab1.mlotab * * CALL ECROBJ('TABLE ',IPO1) * CALL DIMENS * CALL LIRENT(JMA1,1,IRETOU) DO 605 JJ = 1,JMA1 TAPOB1 =mtab1. mtabtv(ivali1+1) TAPOB2 =mtab1. mtabtv(ivali2+1) xvalr1=mtab1.rmtabv(ivali1+1) * TAPIND = 'ENTIER ' * CALL ACCTAB(IPO1,TAPIND,IVALI1,XVALIN,CHARIN, * $ LOGIN,IOBIN,TAPOB1,IVALRE,XVALR1,CHARRE,LOGRE,IOBRE) * if(TAPOB1.EQ.' ') go to 6059 IF (JMA1.EQ.1) THEN XVALR2 = T1 ELSE xvalr2=mtab1.rmtabv(ivali2+1) * CALL ACCTAB(IPO1,TAPIND,IVALI2,XVALIN,CHARIN, * $ LOGIN,IOBIN,TAPOB2,IVALRE,XVALR2,CHARRE,LOGRE,IOBRE) ENDIF IF (IVALI1.EQ.0) THEN IF (T1.LE.XVALR1) THEN DREL = 0.D0 GOTO 607 ENDIF ENDIF IF (IVALI2.EQ.JMA1) 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) GO TO 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) * TAPIND = 'ENTIER ' * CALL ACCTAB(IPO2,TAPIND,IVALI1,XVALIN,CHARIN, * $ LOGIN,IOBIN,TAPOB1,IVALRE,XVALRE,CHARRE,LOGRE,IOBR1) IF (JMA1.EQ.1) THEN IRET = IOBR1 GOTO 668 ENDIF iobr2=mtab2. mtabiv(ivali2+1) segdes mtab2 * CALL ACCTAB(IPO2,TAPIND,IVALI2,XVALIN,CHARIN, * $ LOGIN,IOBIN,TAPOB2,IVALRE,XVALRE,CHARRE,LOGRE,IOBR2) *------ 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 = 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 IRET = IPOSOR ENDIF ELSE IF (TAPOB1.EQ.'MCHAML ') THEN 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 = 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 IRET = IPOSOR ENDIF *-------- la deuxieme table ne pointe pas vers un CHPOINT ou MCHAML ---- 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) CALL DTCHPO(IRET) IF(IRETOU.EQ.0) THEN IF(IRETT.NE.0) THEN CALL DTCHPO(IRETT) ENDIF GOTO 690 ENDIF CALL DTCHPO(IRETT) IRETT=IRETOU ELSE IF (TAPOB1.EQ.'MCHAML ') THEN CALL ADCHEL(IRETT,IRET,IRETOU,1) CALL DTCHEL(IRET) IF(IRETOU.EQ.0) THEN IF(IRETT.NE.0) THEN CALL DTCHEL(IRETT) ENDIF GOTO 690 ENDIF CALL DTCHEL(IRETT) IRETT=IRETOU ENDIF CHATY2 = TAPOB1 ENDIF ENDIF ENDIF SEGDES ICHARG 502 CONTINUE SEGDES MCHARG IF(IRETT.EQ.0) RETURN IF (CHATY2.EQ.'CHPOINT ') THEN CALL ECROBJ('CHPOINT ',IRETT) ELSE CALL ECROBJ('MCHAML ',IRETT) ENDIF RETURN 690 CONTINUE SEGDES MCHARG SEGDES ICHARG 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) = ITYSOL MOTERR(9:12)= 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,MROBO ) 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) = ITYSOL MOTERR(9:12)= 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) = ITYSOL MOTERR(9:12)=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) = ITYSOL MOTERR(9:12)=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 SEGDES MCHPOI 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 SEGDES MCHPOI ENDIF ISOLIT = 34 IRET = MLCHPO SEGDES 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 SEGDES MCHPOI ENDIF ISOLIT = 34 IRET = MLCHPO SEGDES 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 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 C RETURN END