Télécharger la plaquette Cast3M


fr en

Télécharger osci.eso

Retour à la liste

Numérotation des lignes : 

osci

  1. C OSCI      SOURCE    BP208322  16/11/18    21:19:42     9177           
  2.       SUBROUTINE OSCI
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8 (A-H,O-Z)
  5.       CHARACTER*72 TI
  6. C
  7. C     ========================================================
  8. C                                                            =
  9. C     REPONSE D'UN OSCILLATEUR A UNE EXCITATION DONNEE       =
  10. C                                                            =
  11. C     SYNTAXE : EVOL = OSCI EVOL1   AMOR XSI   FREQ DFREQ    =
  12. C                                                            =
  13. C      (TEMP LTEMP) (DEPL XDEP) (VITE XVIT)  (COUL COOL)     =
  14. C                                                            =
  15. C     CREATION : 03/06/87                                    =
  16. C     PROGRAMMEUR : MALAVAL                                  =
  17. C                                                            =
  18. C     ========================================================
  19. C
  20. -INC CCREEL
  21.  
  22. -INC PPARAM
  23. -INC CCOPTIO
  24. -INC SMEVOLL
  25. -INC CCGEOME
  26.       CHARACTER*4 MODOM(6)
  27.       DATA MODOM/'AMOR','FREQ','TEMP','DEPL','VITE','COUL'/
  28.       LMOT=6
  29.       ITEMP=0
  30.       IAMOR=0
  31.       IFREQ=0
  32.       IVITE=0
  33.       IDEPL=0
  34.       ICOUL1=IDCOUL
  35. C
  36. C     LECTURE DES MOTS
  37. C
  38.       DO 10 I=1,6
  39.       CALL LIRMOT(MODOM,LMOT,IPLAC,0)
  40.       IF (IPLAC.EQ.0) GOTO 10
  41. C
  42.   5   GOTO (1,2,3,31,32,4),IPLAC
  43. C
  44.   1   CONTINUE
  45. C
  46. C     AMORTISSEMENT
  47. C
  48.       CALL LIRREE (XSI,1,IRET)
  49.       IAMOR=1
  50.       GOTO 10
  51. C
  52.   2   CONTINUE
  53. C
  54. C     FREQUENCE
  55. C
  56.       CALL LIRREE (DFREQ,1,IRET)
  57.       IFREQ=1
  58.       GOTO 10
  59. C
  60.   3   CONTINUE
  61. C
  62. C     TEMPS
  63. C
  64.       CALL LIROBJ ('LISTREEL',IPT,1,IRET)
  65.       ITEMP=1
  66.       GOTO 10
  67. C
  68.   31  CONTINUE
  69. C
  70. C     DEPLACEMENT INITIAL
  71. C
  72.       CALL LIRREE (XDEP,1,IRET)
  73.       IDEPL=1
  74.       GOTO 10
  75. C
  76.   32  CONTINUE
  77. C
  78. C     VITESSE INITIALE
  79. C
  80.       CALL LIRREE (XVIT,1,IRET)
  81.       IVITE=1
  82.       GOTO 10
  83. C
  84.   4   CONTINUE
  85. C
  86. C     COULEURS
  87. C
  88.       CALL LIRMOT (NCOUL,NBCOUL,ICOUL1,0)
  89.       IF (ICOUL1.EQ.0) ICOUL1=IDCOUL+1
  90.       ICOUL1=ICOUL1-1
  91. C
  92.       GOTO10
  93. C
  94.   10  CONTINUE
  95. C
  96.       IF ( (IAMOR*IFREQ).EQ.0 ) THEN
  97.            CALL ERREUR (26)
  98.            RETURN
  99.       ENDIF
  100.       IF (XSI.LT.0.OR.XSI.GE.1) THEN
  101.             MOTERR(1:8)='AMORTISS'
  102.             REAERR(1)=XSI
  103.             REAERR(2)=0.
  104.             REAERR(3)=1.
  105.             CALL ERREUR(42)
  106.             RETURN
  107.       ENDIF
  108.       IF (IVITE.EQ.0) XVIT=0.
  109.       IF (IDEPL.EQ.0) XDEP=0.
  110. C
  111. C     TEMPS ET ACCELERATION DE L'OBJET EVOLUTION
  112. C
  113.       CALL LIROBJ ('EVOLUTIO',IPOEVO,1,IRET)
  114.       MEVOLL=IPOEVO
  115.       SEGACT MEVOLL
  116.       KEVOLL=IEVOLL(1)
  117.       SEGACT KEVOLL
  118.       IPTG=IPROGX
  119.       IPGG=IPROGY
  120.       SEGDES MEVOLL
  121.       SEGDES KEVOLL
  122.       IF (ITEMP.EQ.0) GOTO 60
  123. C
  124. C     APPEL A LA SUBROUTINE D'INTERPOLATION
  125. C
  126.       CALL INTE33(IPTG,IPGG,IPT,IPG)
  127.       GOTO 70
  128.   60  IPT=IPTG
  129.       IPG=IPGG
  130. C
  131. C     APPEL A LA SUBROUTINE CONTENANT L'ALGORITHME
  132. C
  133.   70  CALL INOSCI(IPT,IPG,DFREQ,XSI,XDEP,XVIT,IPYD)
  134. C
  135. C     CREATION D'UN OBJET EVOLUTION
  136. C
  137.       SEGINI KEVOLL
  138.       IPROGX=IPT
  139.       IPROGY=IPYD
  140.       NOMEVX='TEMPS'
  141.       TYPX='LISTREEL'
  142.       TYPY='LISTREEL'
  143.       NOMEVY='DEPLACEMENT'
  144.       NUMEVX=ICOUL1
  145.       NUMEVY='REEL'
  146. C
  147. C
  148.       N=1
  149.       SEGINI MEVOLL
  150.       IPSOL=MEVOLL
  151.       IEVOLL(1)=KEVOLL
  152.       TI(1:72)=TITREE
  153.       IEVTEX=TI
  154.       ITYEVO='REEL'
  155. c       KEVTEX=TI
  156.       KEVTEX='DEPL'
  157.       SEGDES KEVOLL
  158.       SEGDES MEVOLL
  159. C
  160. C
  161.       CALL ECROBJ ('EVOLUTIO',IPSOL)
  162.       RETURN
  163.       END
  164.  
  165.  
  166.  
  167.  
  168.  
  169.  
  170.  
  171.  
  172.  
  173.  
  174.  
  175.  
  176.  
  177.  
  178.  
  179.  

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