1 : C TIDEP1 SOURCE CHAT 07/10/29 21:29:38 5940 2 : C 3 : SUBROUTINE TIDEP1(T1,IPCH1,MOTYPE,MDEPTY,IPTI4,IPTI5,IPTI6, 4 : $IPTI7,IPCH2) 5 : IMPLICIT INTEGER(I-N) 6 : IMPLICIT REAL*8 (A-H,O-Z) 7 : C=============================================================== 8 : C appele par TIRE, la routine deplace un CHPOINT ou un MCHAML 9 : C suivant les consignes 10 : C en entree : T1, date d'evaluation 11 : C IPCH1, pointeur sur le champ a transformer 12 : C MOTYPE, mot 'MCHAML ' ou 'CHPOINT ' 13 : C MDEPTY, mot precisant le type de mouvement 14 : C IPTI4, pointeur sur un POINT ou une TABLE 15 : C IPTI5, pointeur sur un POINT ou une TABLE 16 : C IPTI6, pointeur sur un LISTREEL (instants t) 17 : C IPTI7, pointeur sur un listreel (vitesses a t) 18 : C en sortie : IPCH2, pointeur sur le champ resultat 19 : C 20 : C CREATION : 10/97, J. KICHENIN 21 : C================================================================ 22 : -INC CCOPTIO 23 : -INC SMCOORD 24 : -INC SMLREEL 25 : -INC SMEVOLL 26 : -INC SMELEME 27 : -INC CCGEOME 28 : SEGMENT ICPR(XCOOR(/1)/(IDIM+1)) 29 : DIMENSION X(3),Y(4) 30 : COMMON /CTOURN/XPT1,YPT1,ZPT1,XV1,YV1,ZV1,XV2,YV2,ZV2,XVEC,YVEC, 31 : # ZVEC,ANGLE,ICLE 32 : CHARACTER*8 MOTYPE,TAPIND,TAPOBJ,TAPOB1,TAPOB2 33 : CHARACTER*4 DMDEP(4),MDEPTY 34 : INTEGER IPCH1,IPCH2,IPTI4,IPTI5,IPTI6,IPTI7 35 : DATA DMDEP/'TRAN','ROTA','TRAJ','STAT'/ 36 : 37 : IF (MDEPTY.EQ.DMDEP(1)) GOTO 100 38 : IF (MDEPTY.EQ.DMDEP(2)) GOTO 100 39 : IF (MDEPTY.EQ.DMDEP(3)) GOTO 300 40 : 41 : C------------- calcul du deplacement eventuel du champ ---------- 42 : 100 CONTINUE 43 : * le mouvement n est pas defini a l'instant r%1 44 : MLREE3 = IPTI6 45 : SEGINI, MLREE1=MLREE3 46 : NF=MLREE1.PROG(/1) 47 : T2 = T1 + ABS(T1*0.000001D0) 48 : T3 = T1 - ABS(T1*0.000001D0) 49 : IF((MLREE1.PROG(1)).GT.T2.OR.(MLREE1.PROG(NF)).LT.T3) THEN 50 : REAERR(1)=T1 50 : CALL ERREUR(342) 51 : RETURN 52 : ENDIF 53 : 54 : * cree une evolution dont T1 est l'instant final 55 : MLREE3 = IPTI7 56 : SEGINI, MLREE2=MLREE3 57 : N = 0 58 : DO 444 ILR = 2,MLREE1.PROG(/1) 59 : IF (MLREE1.PROG(ILR-1).LT.T1.AND.MLREE1.PROG(ILR).GT.T1) THEN 60 : WVALR1 = MLREE1.PROG(ILR-1) 61 : WVALR2 = MLREE1.PROG(ILR) 62 : DREL = (T1 - WVALR1)/(WVALR2 - WVALR1) 63 : MLREE2.PROG(ILR) = (DREL*MLREE2.PROG(ILR-1)) + 64 : $ ((1.D0-DREL)*MLREE2.PROG(ILR)) 65 : MLREE1.PROG(ILR) = T1 66 : JG = ILR 67 : GOTO 445 68 : ELSE IF (MLREE1.PROG(1).EQ.T1) THEN 69 : COAMPL = 0.D0 70 : GOTO 460 71 : ELSE IF (MLREE1.PROG(ILR).EQ.T1) THEN 72 : JG = ILR 73 : GOTO 445 74 : ENDIF 75 : 444 CONTINUE 76 : 445 CONTINUE 77 : SEGADJ MLREE1,MLREE2 78 : N=1 79 : SEGINI MEVOL2 80 : SEGINI KEVOL2 81 : MEVOL2.IEVOLL(1) = KEVOL2 82 : KEVOL2.IPROGX = MLREE1 83 : KEVOL2.IPROGY = MLREE2 84 : SEGDES KEVOL2,MEVOL2 85 : SEGDES MLREE1,MLREE2 86 : 87 : * ecrire EVOLUTIO dans la pile et appeler SOMM puis disposer du reel 87 : CALL ECROBJ('EVOLUTIO',MEVOL2) 87 : CALL SOMM 87 : CALL LIROBJ('LISTREEL',MLREE3,1,IRET1) 88 : IF (IERR.NE.0) RETURN 89 : SEGACT MLREE3 90 : COAMPL = MLREE3.PROG(1) 91 : SEGSUP MLREE3 92 : SEGSUP MEVOL2,KEVOL2,MLREE1,MLREE2 93 : C 94 : 460 CONTINUE 95 : IF (MDEPTY.EQ.DMDEP(2)) GOTO 200 96 : * 'TRAN' : ecrire un POINT, puis un CHPOINT ou MCHAML, et appeler PROPER 97 : SEGACT MCOORD 98 : IREF=IPTI4*(IDIM+1)-IDIM 99 : X(1)=XCOOR(IREF) 100 : X(2)=XCOOR(IREF+1) 101 : IF (IDIM.GE.3) X(3)=XCOOR(IREF+2) 102 : NBPTS=XCOOR(/1)/(IDIM+1)+1 103 : SEGADJ MCOORD 104 : XCOOR((NBPTS-1)*(IDIM+1)+1)=X(1)*COAMPL 105 : XCOOR((NBPTS-1)*(IDIM+1)+2)=X(2)*COAMPL 106 : IF (IDIM.GE.3) XCOOR((NBPTS-1)*(IDIM+1)+3)=X(3)*COAMPL 107 : XCOOR(NBPTS*(IDIM+1))=DENSIT 108 : IPRET=NBPTS 108 : CALL ECROBJ('POINT ',IPRET) 109 : IF(MOTYPE.EQ.'CHPOINT ') THEN 109 : CALL ECROBJ('CHPOINT ',IPCH1) 110 : ELSE 110 : CALL ECROBJ('MCHAML ',IPCH1) 111 : ENDIF 111 : CALL PROPER(1) 112 : IF (MOTYPE.EQ.'CHPOINT ') THEN 112 : CALL LIROBJ('CHPOINT ',IPCH2,1,IRET1) 113 : ELSE 113 : CALL LIROBJ('MCHAML ',IPCH2,1,IRET1) 114 : ENDIF 115 : RETURN 116 : * 117 : 200 CONTINUE 118 : C 'ROTA' : ecrire un CHPOINT, ou MCHAML , un FLOTTANT, 119 : c un ou deux POINT(s) pour l'axe de rotation, puis appeler TOURNE 119 : CALL ECRREE(COAMPL) 119 : IF (IDIM.GE.3) CALL ECROBJ('POINT ',IPTI5) 119 : CALL ECROBJ('POINT ', IPTI4) 120 : IF (MOTYPE.EQ.'CHPOINT ') THEN 120 : CALL ECROBJ('CHPOINT ',IPCH1) 121 : ELSE 121 : CALL ECROBJ('MCHAML ',IPCH1) 122 : ENDIF 122 : CALL TOURNE 123 : IF (MOTYPE.EQ.'CHPOINT ') THEN 123 : CALL LIROBJ('CHPOINT ',IPCH2,1,IRET1) 124 : ELSE 124 : CALL LIROBJ('MCHAML ',IPCH2,1,IRET1) 125 : ENDIF 126 : * 127 : RETURN 128 : 129 : 300 CONTINUE 130 : C 'TRAJ' 131 : * se situer dans la progression des temps et extrapoler la position 132 : MLREE1 = IPTI6 133 : SEGACT MLREE1 134 : NF=MLREE1.PROG(/1) 135 : T2 = T1 + ABS(T1*0.000001D0) 136 : T3 = T1 - ABS(T1*0.000001D0) 137 : IF((MLREE1.PROG(1)).GT.T2.OR.(MLREE1.PROG(NF)).LT.T3) THEN 138 : REAERR(1)=T1 138 : CALL ERREUR(342) 139 : RETURN 140 : ENDIF 141 : 142 : DO 344 ILR = 2,MLREE1.PROG(/1) 143 : IF (MLREE1.PROG(ILR-1).LE.T1.AND.MLREE1.PROG(ILR).GE.T1) THEN 144 : WVALR1 = MLREE1.PROG(ILR-1) 145 : WVALR2 = MLREE1.PROG(ILR) 146 : IF ((WVALR2 - WVALR1).EQ.0) THEN 147 : SEGDES MLREE1 147 : CALL ERREUR(1) 148 : RETURN 149 : ENDIF 150 : DREL = (T1 - WVALR1)/(WVALR2 - WVALR1) 151 : SEGDES MLREE1 152 : GOTO 350 153 : ENDIF 154 : 344 CONTINUE 155 : 156 : 350 CONTINUE 157 : MELEME = IPTI5 158 : SEGACT MELEME 159 : IF (ITYPEL.NE.1) THEN 160 : SEGDES MELEME 161 : RETURN 162 : ENDIF 163 : IOBR0 = NUM(1,1) 164 : IOBR1 = NUM(1,ILR-1) 165 : IOBR2 = NUM(1,ILR) 166 : SEGDES MELEME 166 : CALL ECROBJ('POINT ',IOBR1) 166 : CALL ECRREE(1.D0 - DREL) 166 : CALL OPERMU 166 : CALL LIROBJ('POINT ',IOBR1,1,IRETOU) 166 : CALL ECROBJ('POINT ',IOBR2) 166 : CALL ECRREE(DREL) 166 : CALL OPERMU 166 : CALL ECROBJ('POINT ',IOBR1) 166 : CALL PROPER(1) 166 : CALL LIROBJ('POINT ',IOBR1,1,IRETOU) 166 : CALL ECROBJ('POINT ',IOBR0) 166 : CALL ECROBJ('POINT ',IOBR1) 166 : CALL PROPER(2) 166 : CALL LIROBJ('POINT ',IOBR1,1,IRETOU) 166 : CALL ECROBJ('POINT ',IOBR1) 166 : CALL ECROBJ('CHPOINT ',IPCH1) 166 : CALL PROPER(1) 166 : CALL LIROBJ('CHPOINT ',IPCH2,1,IRETOU) 167 : C 168 : RETURN 169 : END 170 : 171 : 172 : 173 : 174 :
© Cast3M 2003 - All rights reserved.
Disclaimer