C TIDEP1 SOURCE CHAT 07/10/29 21:29:38 5940 C SUBROUTINE TIDEP1(T1,IPCH1,MOTYPE,MDEPTY,IPTI4,IPTI5,IPTI6, $IPTI7,IPCH2) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) C=============================================================== C appele par TIRE, la routine deplace un CHPOINT ou un MCHAML C suivant les consignes C en entree : T1, date d'evaluation C IPCH1, pointeur sur le champ a transformer C MOTYPE, mot 'MCHAML ' ou 'CHPOINT ' C MDEPTY, mot precisant le type de mouvement C IPTI4, pointeur sur un POINT ou une TABLE C IPTI5, pointeur sur un POINT ou une TABLE C IPTI6, pointeur sur un LISTREEL (instants t) C IPTI7, pointeur sur un listreel (vitesses a t) C en sortie : IPCH2, pointeur sur le champ resultat C C CREATION : 10/97, J. KICHENIN C================================================================ -INC CCOPTIO -INC SMCOORD -INC SMLREEL -INC SMEVOLL -INC SMELEME -INC CCGEOME 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 CHARACTER*8 MOTYPE,TAPIND,TAPOBJ,TAPOB1,TAPOB2 CHARACTER*4 DMDEP(4),MDEPTY INTEGER IPCH1,IPCH2,IPTI4,IPTI5,IPTI6,IPTI7 DATA DMDEP/'TRAN','ROTA','TRAJ','STAT'/ IF (MDEPTY.EQ.DMDEP(1)) GOTO 100 IF (MDEPTY.EQ.DMDEP(2)) GOTO 100 IF (MDEPTY.EQ.DMDEP(3)) GOTO 300 C------------- calcul du deplacement eventuel du champ ---------- 100 CONTINUE * le mouvement n est pas defini a l'instant r%1 MLREE3 = IPTI6 SEGINI, MLREE1=MLREE3 NF=MLREE1.PROG(/1) T2 = T1 + ABS(T1*0.000001D0) T3 = T1 - ABS(T1*0.000001D0) IF((MLREE1.PROG(1)).GT.T2.OR.(MLREE1.PROG(NF)).LT.T3) THEN REAERR(1)=T1 CALL ERREUR(342) RETURN ENDIF * cree une evolution dont T1 est l'instant final MLREE3 = IPTI7 SEGINI, MLREE2=MLREE3 N = 0 DO 444 ILR = 2,MLREE1.PROG(/1) IF (MLREE1.PROG(ILR-1).LT.T1.AND.MLREE1.PROG(ILR).GT.T1) THEN WVALR1 = MLREE1.PROG(ILR-1) WVALR2 = MLREE1.PROG(ILR) DREL = (T1 - WVALR1)/(WVALR2 - WVALR1) MLREE2.PROG(ILR) = (DREL*MLREE2.PROG(ILR-1)) + $ ((1.D0-DREL)*MLREE2.PROG(ILR)) MLREE1.PROG(ILR) = T1 JG = ILR GOTO 445 ELSE IF (MLREE1.PROG(1).EQ.T1) THEN COAMPL = 0.D0 GOTO 460 ELSE IF (MLREE1.PROG(ILR).EQ.T1) THEN JG = ILR GOTO 445 ENDIF 444 CONTINUE 445 CONTINUE SEGADJ MLREE1,MLREE2 N=1 SEGINI MEVOL2 SEGINI KEVOL2 MEVOL2.IEVOLL(1) = KEVOL2 KEVOL2.IPROGX = MLREE1 KEVOL2.IPROGY = MLREE2 SEGDES KEVOL2,MEVOL2 SEGDES MLREE1,MLREE2 * ecrire EVOLUTIO dans la pile et appeler SOMM puis disposer du reel CALL ECROBJ('EVOLUTIO',MEVOL2) CALL SOMM CALL LIROBJ('LISTREEL',MLREE3,1,IRET1) IF (IERR.NE.0) RETURN SEGACT MLREE3 COAMPL = MLREE3.PROG(1) SEGSUP MLREE3 SEGSUP MEVOL2,KEVOL2,MLREE1,MLREE2 C 460 CONTINUE IF (MDEPTY.EQ.DMDEP(2)) GOTO 200 * 'TRAN' : ecrire un POINT, puis un CHPOINT ou MCHAML, et appeler PROPER SEGACT MCOORD IREF=IPTI4*(IDIM+1)-IDIM X(1)=XCOOR(IREF) X(2)=XCOOR(IREF+1) IF (IDIM.GE.3) X(3)=XCOOR(IREF+2) NBPTS=XCOOR(/1)/(IDIM+1)+1 SEGADJ MCOORD XCOOR((NBPTS-1)*(IDIM+1)+1)=X(1)*COAMPL XCOOR((NBPTS-1)*(IDIM+1)+2)=X(2)*COAMPL IF (IDIM.GE.3) XCOOR((NBPTS-1)*(IDIM+1)+3)=X(3)*COAMPL XCOOR(NBPTS*(IDIM+1))=DENSIT IPRET=NBPTS CALL ECROBJ('POINT ',IPRET) IF(MOTYPE.EQ.'CHPOINT ') THEN CALL ECROBJ('CHPOINT ',IPCH1) ELSE CALL ECROBJ('MCHAML ',IPCH1) ENDIF CALL PROPER(1) IF (MOTYPE.EQ.'CHPOINT ') THEN CALL LIROBJ('CHPOINT ',IPCH2,1,IRET1) ELSE CALL LIROBJ('MCHAML ',IPCH2,1,IRET1) ENDIF RETURN * 200 CONTINUE C 'ROTA' : ecrire un CHPOINT, ou MCHAML , un FLOTTANT, c un ou deux POINT(s) pour l'axe de rotation, puis appeler TOURNE CALL ECRREE(COAMPL) IF (IDIM.GE.3) CALL ECROBJ('POINT ',IPTI5) CALL ECROBJ('POINT ', IPTI4) IF (MOTYPE.EQ.'CHPOINT ') THEN CALL ECROBJ('CHPOINT ',IPCH1) ELSE CALL ECROBJ('MCHAML ',IPCH1) ENDIF CALL TOURNE IF (MOTYPE.EQ.'CHPOINT ') THEN CALL LIROBJ('CHPOINT ',IPCH2,1,IRET1) ELSE CALL LIROBJ('MCHAML ',IPCH2,1,IRET1) ENDIF * RETURN 300 CONTINUE C 'TRAJ' * se situer dans la progression des temps et extrapoler la position MLREE1 = IPTI6 SEGACT MLREE1 NF=MLREE1.PROG(/1) T2 = T1 + ABS(T1*0.000001D0) T3 = T1 - ABS(T1*0.000001D0) IF((MLREE1.PROG(1)).GT.T2.OR.(MLREE1.PROG(NF)).LT.T3) THEN REAERR(1)=T1 CALL ERREUR(342) RETURN ENDIF DO 344 ILR = 2,MLREE1.PROG(/1) IF (MLREE1.PROG(ILR-1).LE.T1.AND.MLREE1.PROG(ILR).GE.T1) THEN WVALR1 = MLREE1.PROG(ILR-1) WVALR2 = MLREE1.PROG(ILR) IF ((WVALR2 - WVALR1).EQ.0) THEN SEGDES MLREE1 CALL ERREUR(1) RETURN ENDIF DREL = (T1 - WVALR1)/(WVALR2 - WVALR1) SEGDES MLREE1 GOTO 350 ENDIF 344 CONTINUE 350 CONTINUE MELEME = IPTI5 SEGACT MELEME IF (ITYPEL.NE.1) THEN SEGDES MELEME RETURN ENDIF IOBR0 = NUM(1,1) IOBR1 = NUM(1,ILR-1) IOBR2 = NUM(1,ILR) SEGDES MELEME CALL ECROBJ('POINT ',IOBR1) CALL ECRREE(1.D0 - DREL) CALL OPERMU CALL LIROBJ('POINT ',IOBR1,1,IRETOU) CALL ECROBJ('POINT ',IOBR2) CALL ECRREE(DREL) CALL OPERMU CALL ECROBJ('POINT ',IOBR1) CALL PROPER(1) CALL LIROBJ('POINT ',IOBR1,1,IRETOU) CALL ECROBJ('POINT ',IOBR0) CALL ECROBJ('POINT ',IOBR1) CALL PROPER(2) CALL LIROBJ('POINT ',IOBR1,1,IRETOU) CALL ECROBJ('POINT ',IOBR1) CALL ECROBJ('CHPOINT ',IPCH1) CALL PROPER(1) CALL LIROBJ('CHPOINT ',IPCH2,1,IRETOU) C RETURN END