C TIDEP1 SOURCE OF166741 25/02/20 21:17:47 12165 C SUBROUTINE TIDEP1(T1,IPCH1,MOTYPE,MDEPTY,IPTI4,IPTI5,IPTI6, $ IPTI7,IPCH2) 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 MELEME ou une TABLE C IPTI5, pointeur sur un MELEME 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================================================================ IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) -INC PPARAM -INC CCOPTIO -INC CCGEOME -INC SMCOORD -INC SMLREEL -INC SMEVOLL -INC SMELEME DIMENSION X(3),Y(4) INTEGER IPCH1,IPCH2,IPTI4,IPTI5,IPTI6,IPTI7 CHARACTER*8 MOTYPE,TAPIND,TAPOBJ,TAPOB1,TAPOB2 CHARACTER*8 CHBOR CHARACTER*4 DMDEP(4),MDEPTY 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.TYPX(1:8)='LISTREEL' KEVOL2.TYPY(1:8)='LISTREEL' KEVOL2.IPROGX = MLREE1 KEVOL2.IPROGY = MLREE2 SEGDES KEVOL2,MEVOL2 SEGDES MLREE1,MLREE2 * ecrire EVOLUTIO dans la pile et appeler INTG puis disposer du reel c CALL ECROBJ('EVOLUTIO',MEVOL2) cbp CALL SOMM c CALL INTGRA c CALL LIROBJ('LISTREEL',MLREE3,1,IRET1) cbp : on branche directement INTGEV XINT=0.D0 IPINT=0 IABSO=0 IA=0 IB=0 CALL INTGEV(MEVOL2,0,0,0,0,0,XINT,IPINT,IK) IF (IERR.NE.0) RETURN COAMPL = XINT 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*mod IPREF = IPTPOI(IPTI4) IREF=IPREF*(IDIM+1)-IDIM X(1)=XCOOR(IREF) X(2)=XCOOR(IREF+1) IF (IDIM.GE.3) X(3)=XCOOR(IREF+2) NBPTS=nbpts+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) THEN IPREF = IPTPOI(IPTI5) CALL ECROBJ('POINT ',IPREF) ENDIF IPREF = IPTPOI(IPTI4) CALL ECROBJ('POINT ', IPREF) 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) RETURN END