Télécharger la plaquette Cast3M


fr en

Télécharger tidep1.eso

Retour à la liste

Numérotation des lignes : 

tidep1

  1. C TIDEP1    SOURCE    PASCAL    20/11/13    21:15:18     10778          
  2. C
  3.       SUBROUTINE TIDEP1(T1,IPCH1,MOTYPE,MDEPTY,IPTI4,IPTI5,IPTI6,
  4.      $                  IPTI7,IPCH2)
  5.  
  6. C===============================================================
  7. C   appele par TIRE, la routine deplace un CHPOINT ou un MCHAML
  8. C suivant les consignes
  9. C en entree :    T1, date d'evaluation
  10. C             IPCH1, pointeur sur le champ a transformer
  11. C            MOTYPE, mot 'MCHAML  ' ou 'CHPOINT '
  12. C            MDEPTY, mot precisant le type de mouvement
  13. C             IPTI4, pointeur sur un MELEME ou une TABLE
  14. C             IPTI5, pointeur sur un MELEME ou une TABLE
  15. C             IPTI6, pointeur sur un LISTREEL (instants t)
  16. C             IPTI7, pointeur sur un listreel (vitesses a t)
  17. C en sortie : IPCH2, pointeur sur le champ resultat
  18. C
  19. C CREATION : 10/97, J. KICHENIN
  20. C================================================================
  21.       IMPLICIT INTEGER(I-N)
  22.       IMPLICIT REAL*8 (A-H,O-Z)
  23.  
  24.  
  25. -INC PPARAM
  26. -INC CCOPTIO
  27. -INC CCGEOME
  28.  
  29. -INC SMCOORD
  30. -INC SMLREEL
  31. -INC SMEVOLL
  32. -INC SMELEME
  33.  
  34.       DIMENSION X(3),Y(4)
  35.       INTEGER IPCH1,IPCH2,IPTI4,IPTI5,IPTI6,IPTI7
  36.       CHARACTER*8 MOTYPE,TAPIND,TAPOBJ,TAPOB1,TAPOB2
  37.       CHARACTER*8 CHBOR
  38.       CHARACTER*4 DMDEP(4),MDEPTY
  39.       DATA DMDEP/'TRAN','ROTA','TRAJ','STAT'/
  40.  
  41.       IF (MDEPTY.EQ.DMDEP(1)) GOTO 100
  42.       IF (MDEPTY.EQ.DMDEP(2)) GOTO 100
  43.       IF (MDEPTY.EQ.DMDEP(3)) GOTO 300
  44.  
  45. C------------- calcul du deplacement eventuel du champ ----------
  46.  100  CONTINUE
  47. * le mouvement n est pas defini a l'instant r%1
  48.       MLREE3 = IPTI6
  49.       SEGINI, MLREE1=MLREE3
  50.       NF = MLREE1.PROG(/1)
  51.       T2 = T1 + ABS(T1*0.000001D0)
  52.       T3 = T1 - ABS(T1*0.000001D0)
  53.       IF((MLREE1.PROG(1)).GT.T2.OR.(MLREE1.PROG(NF)).LT.T3) THEN
  54.         REAERR(1)=T1
  55.         CALL ERREUR(342)
  56.         RETURN
  57.       ENDIF
  58.  
  59. * cree une evolution dont T1 est l'instant final
  60.       MLREE3 = IPTI7
  61.       SEGINI, MLREE2=MLREE3
  62.       N = 0
  63.       DO 444 ILR = 2,MLREE1.PROG(/1)
  64.         IF (MLREE1.PROG(ILR-1).LT.T1.AND.MLREE1.PROG(ILR).GT.T1) THEN
  65.           WVALR1 = MLREE1.PROG(ILR-1)
  66.           WVALR2 = MLREE1.PROG(ILR)
  67.           DREL = (T1 - WVALR1)/(WVALR2 - WVALR1)
  68.           MLREE2.PROG(ILR) = (DREL*MLREE2.PROG(ILR-1)) +
  69.      $                ((1.D0-DREL)*MLREE2.PROG(ILR))
  70.           MLREE1.PROG(ILR) = T1
  71.           JG = ILR
  72.           GOTO 445
  73.         ELSE IF (MLREE1.PROG(1).EQ.T1) THEN
  74.           COAMPL = 0.D0
  75.           GOTO 460
  76.         ELSE IF (MLREE1.PROG(ILR).EQ.T1) THEN
  77.           JG = ILR
  78.           GOTO 445
  79.         ENDIF
  80.   444 CONTINUE
  81.   445 CONTINUE
  82.       SEGADJ MLREE1,MLREE2
  83.       N=1
  84.       SEGINI MEVOL2
  85.       SEGINI KEVOL2
  86.       MEVOL2.IEVOLL(1) = KEVOL2
  87.       KEVOL2.TYPX(1:8)='LISTREEL'
  88.       KEVOL2.TYPY(1:8)='LISTREEL'
  89.       KEVOL2.IPROGX = MLREE1
  90.       KEVOL2.IPROGY = MLREE2
  91.       SEGDES KEVOL2,MEVOL2
  92.       SEGDES MLREE1,MLREE2
  93.  
  94. * ecrire EVOLUTIO dans la pile et appeler INTG puis disposer du reel
  95. c       CALL ECROBJ('EVOLUTIO',MEVOL2)
  96. cbp       CALL SOMM
  97. c       CALL INTGRA
  98. c       CALL LIROBJ('LISTREEL',MLREE3,1,IRET1)
  99. cbp : on branche directement INTGEV
  100.       XINT=0.D0
  101.       IPINT=0
  102.       IABSO=0
  103.       IA=0
  104.       IB=0
  105.       CALL INTGEV(MEVOL2,0,0,0,0,0,XINT,IPINT,IK)
  106.       IF (IERR.NE.0) RETURN
  107.       COAMPL = XINT
  108.       SEGSUP MEVOL2,KEVOL2,MLREE1,MLREE2
  109. C
  110.  460  CONTINUE
  111.       IF (MDEPTY.EQ.DMDEP(2)) GOTO 200
  112. * 'TRAN' : ecrire un POINT, puis un CHPOINT ou MCHAML, et appeler PROPER
  113.       SEGACT MCOORD*mod
  114.       IPREF = IPTPOI(IPTI4)
  115.       IREF=IPREF*(IDIM+1)-IDIM
  116.       X(1)=XCOOR(IREF)
  117.       X(2)=XCOOR(IREF+1)
  118.       IF (IDIM.GE.3) X(3)=XCOOR(IREF+2)
  119.       NBPTS=nbpts+1
  120.       SEGADJ MCOORD
  121.       XCOOR((NBPTS-1)*(IDIM+1)+1)=X(1)*COAMPL
  122.       XCOOR((NBPTS-1)*(IDIM+1)+2)=X(2)*COAMPL
  123.       IF (IDIM.GE.3) XCOOR((NBPTS-1)*(IDIM+1)+3)=X(3)*COAMPL
  124.       XCOOR(NBPTS*(IDIM+1))=DENSIT
  125.       IPRET=NBPTS
  126.       CALL ECROBJ('POINT ',IPRET)
  127.       IF(MOTYPE.EQ.'CHPOINT ') THEN
  128.         CALL ECROBJ('CHPOINT ',IPCH1)
  129.       ELSE
  130.         CALL ECROBJ('MCHAML  ',IPCH1)
  131.       ENDIF
  132.       CALL PROPER(1)
  133.       IF (MOTYPE.EQ.'CHPOINT ') THEN
  134.         CALL LIROBJ('CHPOINT ',IPCH2,1,IRET1)
  135.       ELSE
  136.         CALL LIROBJ('MCHAML  ',IPCH2,1,IRET1)
  137.       ENDIF
  138.       RETURN
  139. *
  140.   200 CONTINUE
  141. C 'ROTA' : ecrire un CHPOINT, ou MCHAML , un FLOTTANT,
  142. c un ou deux POINT(s) pour l'axe de rotation, puis appeler  TOURNE
  143.       CALL ECRREE(COAMPL)
  144.       IF (IDIM.GE.3) THEN
  145.         IPREF = IPTPOI(IPTI5)
  146.         CALL ECROBJ('POINT   ',IPREF)
  147.       ENDIF
  148.       IPREF = IPTPOI(IPTI4)
  149.       CALL ECROBJ('POINT ', IPREF)
  150.       IF (MOTYPE.EQ.'CHPOINT ') THEN
  151.         CALL ECROBJ('CHPOINT ',IPCH1)
  152.       ELSE
  153.         CALL ECROBJ('MCHAML  ',IPCH1)
  154.       ENDIF
  155.       CALL TOURNE
  156.       IF (MOTYPE.EQ.'CHPOINT ') THEN
  157.         CALL LIROBJ('CHPOINT ',IPCH2,1,IRET1)
  158.       ELSE
  159.         CALL LIROBJ('MCHAML  ',IPCH2,1,IRET1)
  160.       ENDIF
  161. *
  162.       RETURN
  163.  
  164.  300  CONTINUE
  165. C 'TRAJ'
  166. * se situer dans la progression des temps et extrapoler la position
  167.       MLREE1 = IPTI6
  168.       SEGACT MLREE1
  169.       NF=MLREE1.PROG(/1)
  170.       T2 = T1 + ABS(T1*0.000001D0)
  171.       T3 = T1 - ABS(T1*0.000001D0)
  172.       IF((MLREE1.PROG(1)).GT.T2.OR.(MLREE1.PROG(NF)).LT.T3) THEN
  173.         REAERR(1)=T1
  174.         CALL ERREUR(342)
  175.         RETURN
  176.       ENDIF
  177.  
  178.       DO 344 ILR = 2,MLREE1.PROG(/1)
  179.         IF (MLREE1.PROG(ILR-1).LE.T1.AND.MLREE1.PROG(ILR).GE.T1) THEN
  180.           WVALR1 = MLREE1.PROG(ILR-1)
  181.           WVALR2 = MLREE1.PROG(ILR)
  182.           IF ((WVALR2 - WVALR1).EQ.0) THEN
  183.              SEGDES MLREE1
  184.              CALL ERREUR(1)
  185.              RETURN
  186.           ENDIF
  187.           DREL = (T1 - WVALR1)/(WVALR2 - WVALR1)
  188.           SEGDES MLREE1
  189.           GOTO 350
  190.         ENDIF
  191.  344  CONTINUE
  192.  
  193.  350  CONTINUE
  194.       MELEME = IPTI5
  195.       SEGACT MELEME
  196.         IF (ITYPEL.NE.1) THEN
  197.            SEGDES MELEME
  198.            RETURN
  199.         ENDIF
  200.       IOBR0 = NUM(1,1)
  201.       IOBR1 = NUM(1,ILR-1)
  202.       IOBR2 = NUM(1,ILR)
  203.       SEGDES MELEME
  204.       CALL ECROBJ('POINT ',IOBR1)
  205.       CALL ECRREE(1.D0 - DREL)
  206.       CALL OPERMU
  207.       CALL LIROBJ('POINT ',IOBR1,1,IRETOU)
  208.       CALL ECROBJ('POINT ',IOBR2)
  209.       CALL ECRREE(DREL)
  210.       CALL OPERMU
  211.       CALL ECROBJ('POINT ',IOBR1)
  212.       CALL PROPER(1)
  213.       CALL LIROBJ('POINT ',IOBR1,1,IRETOU)
  214.       CALL ECROBJ('POINT ',IOBR0)
  215.       CALL ECROBJ('POINT ',IOBR1)
  216.       CALL PROPER(2)
  217.       CALL LIROBJ('POINT ',IOBR1,1,IRETOU)
  218.       CALL ECROBJ('POINT ',IOBR1)
  219.       CALL ECROBJ('CHPOINT ',IPCH1)
  220.       CALL PROPER(1)
  221.       CALL LIROBJ('CHPOINT ',IPCH2,1,IRETOU)
  222.  
  223.       RETURN
  224.       END
  225.  
  226.  
  227.  
  228.  
  229.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales