Télécharger la plaquette Cast3M


fr en

Télécharger spo.eso

Retour à la liste

Numérotation des lignes : 

spo

  1. C SPO       SOURCE    PV        16/06/24    13:07:54     8985           
  2.       SUBROUTINE SPO
  3.       IMPLICIT INTEGER(I-N)
  4.       IMPLICIT REAL*8(A-H,O-Z)
  5.       CHARACTER*72 TI
  6.       CHARACTER*(4) CMOT
  7. c
  8. c     ========================================================
  9. c                                                            =
  10. c     spectres d' oscillateur                                =
  11. c                                                            =
  12. c     syntaxe : evol = spo evol1   amor lamor  (freq lfreq)  =
  13. c                                                            =
  14. c                      (temp ltemp)   (coul cool)  sortie    =
  15. c                                                            =
  16. c     creation : 03/06/87                                    =
  17. c     programmeur : malaval                                  =
  18. c                                                            =
  19. c     modification : 17/12/90                                =
  20. c     programmeur : a.pinto and p.pegon                      =
  21. c                                                            =
  22. c     ========================================================
  23. c
  24.  
  25. -INC PPARAM
  26. -INC CCOPTIO
  27. -INC SMEVOLL
  28. -INC SMLREEL
  29. -INC CCGEOME
  30. -INC CCREEL
  31. cap 7-->8, 3-->4 et vrai acc
  32.       CHARACTER*4 MODOM(8)
  33.       CHARACTER*12 ITITY(4)
  34.       DATA MODOM/'AMOR','FREQ','TEMP','COUL','DEPL','VITE','ACCE',
  35.      *'ACCA'/
  36.       DATA ITITY /'DEPLMAXIMAUX','PSEUDO VITES','PSEUDO ACCEL',
  37.      *'ABSOLUTE ACC'/
  38.       LMOT=8
  39. cap
  40.       ITEMP=0
  41.       IAMOR=0
  42.       IFREQ=0
  43.       ICOUL1=IDCOUL
  44.       N0=0
  45. c
  46. c     lecture des mots
  47. c
  48.       DO 10 I=1,5
  49.       CALL LIRMOT(MODOM,LMOT,IPLAC,0)
  50.       IF (IPLAC.EQ.0) GOTO 10
  51. cap +12
  52.   8   GOTO (1,2,3,4,5,6,7,12),IPLAC
  53. cap
  54.   1   CONTINUE
  55. c
  56. c     amortissement
  57. c
  58.       CALL LIROBJ ('LISTREEL',IPAMOR,1,IRET)
  59.       IAMOR=1
  60.       GOTO 10
  61. c
  62.   2   CONTINUE
  63. c
  64. c     frequence
  65. c
  66.       CALL LIROBJ ('LISTREEL',IPFREQ,1,IRET)
  67.       IFREQ=1
  68.       GOTO 10
  69. c
  70.   3   CONTINUE
  71. c
  72. c     temps
  73. c
  74.       CALL LIROBJ ('LISTREEL',IPT,1,IRET)
  75.       ITEMP=1
  76.       GOTO 10
  77. c
  78.   4   CONTINUE
  79. c
  80. c     couleurs
  81. c
  82.       CALL LIRMOT (NCOUL(0),NBCOUL,ICOUL1,0)
  83.       IF (ICOUL1.EQ.0) ICOUL1=IDCOUL+1
  84.       ICOUL1=ICOUL1-1
  85.       GOTO10
  86. c
  87.    5  CONTINUE
  88. c
  89. c     spectre en deplacement relatif
  90. c
  91.       N0=1
  92.       GOTO 10
  93. c
  94.   6   CONTINUE
  95. c
  96. c     spectre en pseudo vitesse
  97. c
  98.       N0=2
  99.       GOTO 10
  100. c
  101.   7   CONTINUE
  102. c
  103. c     spectre en pseudo acceleration
  104. c
  105.       N0=3
  106.       GOTO 10
  107. cap
  108.  12   CONTINUE
  109. c
  110. c     spectre en acceleration absolute
  111. c
  112.       N0=4
  113.       GOTO 10
  114. cap
  115. c
  116.   10  CONTINUE
  117. c
  118.       IF (N0.EQ.0 ) THEN
  119.            CALL ERREUR (6)
  120.            RETURN
  121.       ENDIF
  122. c
  123.       IF (IAMOR.EQ.0 ) THEN
  124.            CALL ERREUR (361)
  125.            RETURN
  126.       ENDIF
  127.       MLREEL=IPAMOR
  128.       SEGACT MLREEL
  129.       DO 11 NBAM=1,PROG(/1)
  130.       IF (PROG(NBAM).LT.0.OR.PROG(NBAM).GE.1) THEN
  131.            MOTERR(1:8)='AMORTISS'
  132.            REAERR(1)=PROG(NBAM)
  133.            REAERR(2)=0.
  134.            REAERR(3)=1.
  135.            SEGDES MLREEL
  136.            CALL ERREUR(42)
  137.            RETURN
  138.       ENDIF
  139.  11   CONTINUE
  140.       SEGDES MLREEL
  141. c
  142. c     temps et acceleration de l'objet evolution
  143. c
  144.       CALL LIROBJ ('EVOLUTIO',IPOEVO,1,IRET)
  145.       MEVOLL=IPOEVO
  146.       SEGACT MEVOLL
  147.       KEVOLL=IEVOLL(1)
  148.       SEGACT KEVOLL
  149.       IPTG=IPROGX
  150.       IPGG=IPROGY
  151.       SEGDES MEVOLL
  152.       SEGDES KEVOLL
  153.       IF (ITEMP.EQ.0) THEN
  154.            MLREE1=IPTG
  155.            SEGACT MLREE1
  156.            MLREE2=IPGG
  157.            SEGACT MLREE2
  158.            LONT=MLREE1.PROG(/1)
  159.            TPS=MLREE1.PROG(LONT)
  160.            DT=TPS/(LONT-1)
  161.            NA=TPS/(2*DT)
  162.            JG = LONT+NA
  163.            SEGINI MLREEL
  164.            IPT=MLREEL
  165.            SEGINI MLREE3
  166.            IPG=MLREE3
  167.            TPT=3*TPS/2
  168.            DO 51 LL=1,LONT
  169.              MLREEL.PROG(LL)=MLREE1.PROG(LL)
  170.              MLREE3.PROG(LL)=MLREE2.PROG(LL)
  171.   51       CONTINUE
  172.            DO 52 LL=LONT,(LONT+NA-1)
  173.              MLREEL.PROG(LL+1)=MLREEL.PROG(LL)+DT
  174.              MLREE3.PROG(LL+1)=0.D0
  175.   52       CONTINUE
  176.            TPSMAX = MLREE3.PROG(LONT+NA-2)
  177.            SEGDES MLREE1
  178.            SEGDES MLREE2
  179.            SEGDES MLREEL
  180.            SEGDES MLREE3
  181.            GOTO 70
  182.       ELSE
  183.           MLREE3=IPT
  184.           SEGACT MLREE3
  185.           LONT = MLREE3.PROG(/1)
  186.           TPSMAX = MLREE3.PROG(LONT-2)
  187.           SEGDES MLREE3
  188.  
  189. c
  190. c     appel a la subroutine d'interpolation
  191. c
  192.         CALL INTE33(IPTG,IPGG,IPT,IPG)
  193.  
  194.       ENDIF
  195. c
  196. c
  197. c     appel a la subroutine contenant l'algorithme
  198. c
  199.   70  MLREEL=IPAMOR
  200.       SEGACT MLREEL
  201.       N1=MLREEL.PROG(/1)
  202.       N=N1
  203.       SEGINI MEVOLL
  204.       IPOEVO=MEVOLL
  205. c
  206. c     creation eventuelle d'une liste de frequences
  207. c
  208.       IF (IFREQ.EQ.0) THEN
  209.              MLREE3=IPTG
  210.              SEGACT MLREE3
  211.              LONT=MLREE3.PROG(/1)
  212.              TPS=MLREE3.PROG(LONT)
  213.              SEGDES MLREE3
  214. c
  215. c     pas moyen du signal
  216. c
  217.              DT=TPS/(LONT-1)
  218. c
  219. c     frequence la plus basse
  220. c
  221.              F1=1/TPS
  222. c
  223. c     frequence la plus haute
  224. c
  225.              F3=1/(2*DT)
  226. c
  227.       ELSE
  228.              MLREE3=IPTG
  229.              SEGACT MLREE3
  230.              LONT=MLREE3.PROG(/1)
  231.              TPS=MLREE3.PROG(LONT)
  232.              SEGDES MLREE3
  233.       ENDIF
  234. c
  235. c     boucle sur les differents amortissements
  236. c
  237.       DO 100 I=1,N1
  238. c     mlreel=ipamor
  239.       XSI=MLREEL.PROG(I)
  240.       JG=0
  241.       SEGINI MLREE2
  242.       IPSPO=MLREE2
  243.       IF (IFREQ.NE.0) GOTO 42
  244. c
  245. c     frequence de separation
  246. c
  247.       IF (XSI.NE.0.) THEN
  248.         F2=1/(XSI*TPS)
  249.       ELSE
  250.         F2=F3
  251.       ENDIF
  252. c
  253. c     nombre d'intervalles successifs de largeur f1 entre f1 et f2
  254. c
  255.       N3=(F2-F1)/F1
  256. c
  257. c
  258. c     creation de l'objet listreel
  259. c
  260.       JG=N3
  261.       SEGINI MLREE1
  262.       IPFREQ=MLREE1
  263.       MLREE1.PROG(1)=F1
  264.       DO 102 K=1,N3-1
  265.       MLREE1.PROG(K+1)=MLREE1.PROG(K)+F1
  266.  102  CONTINUE
  267.       Z=MLREE1.PROG(N3)
  268.       IF (Z.NE.F2) THEN
  269.       JG=N3+1
  270.       SEGADJ MLREE1
  271.       MLREE1.PROG(JG)=F2
  272.       N5=N3+1
  273.         ELSE
  274.       N5=N3
  275.         ENDIF
  276. c
  277. c     nombre des intervalles de largeur variable , pris en compte
  278. c     entre f2 et f3
  279. c
  280.       IF (XSI.NE.0.) THEN
  281.          N4=N5+(LOG(F3/F2)/LOG(1+XSI))
  282.          JG=N4
  283.          SEGADJ MLREE1
  284.          DO 103 K=N5,N4-1
  285.          MLREE1.PROG(K+1)=(1+XSI)*MLREE1.PROG(K)
  286.   103    CONTINUE
  287.          SEGDES MLREE1
  288.       ENDIF
  289. c
  290.    42 MLREE1=IPFREQ
  291.       SEGACT MLREE1
  292.       N2=MLREE1.PROG(/1)
  293.       M=0
  294. c
  295. c
  296. c        boucle sur les frequences
  297. c
  298.  
  299.       JG0=MLREE2.PROG(/1)
  300.       JG=JG0+N2
  301.       SEGADJ MLREE2
  302.       DO 101 J=1,N2
  303. c     mlree1=ipfreq
  304.       DFREQ=MLREE1.PROG(J)
  305.       W=2*XPI*DFREQ
  306.       W2=W*W
  307. cap
  308.       CALL INOSC1 (IPT,IPG,DFREQ,XSI,RMAX,TMAX,AMAX)
  309. cap
  310.       IF (TMAX.GT.TPS) THEN
  311. c  le maximum est atteint près la fin du signal
  312.          IF ( (TMAX-TPSMAX) .GE. 0.D0)THEN
  313. c  le maximum est atteint a la fin de l'intervale d'étude : mauvais !
  314.            REAERR(1)=XSI
  315.            REAERR(2)=DFREQ
  316.            CALL ERREUR(-311)
  317.          ENDIF
  318.          M=M+1
  319.       ENDIF
  320. c     mlree2=ipspo
  321.       IF (N0.EQ.1) MLREE2.PROG(JG0+J)=RMAX
  322.       IF (N0.EQ.2) MLREE2.PROG(JG0+J)=W*RMAX
  323.       IF (N0.EQ.3) MLREE2.PROG(JG0+J)=W2*RMAX
  324. cap
  325.       IF (N0.EQ.4) MLREE2.PROG(JG0+J)=AMAX
  326. cap
  327.   101    CONTINUE
  328. c
  329. c   message pour signaler que le maximum est atteint apres la fin du signal
  330. c
  331.       IF ( M .NE. 0) THEN
  332.          REAERR(1)=XSI
  333.          INTERR(1)=M
  334.          CALL ERREUR(-312)
  335.       ENDIF
  336. c
  337.       SEGINI KEVOLL
  338.       IEVOLL(I)=KEVOLL
  339.       TYPX='LISTREEL'
  340.       TYPY='LISTREEL'
  341.       IPROGX=IPFREQ
  342.       IPROGY=IPSPO
  343.       NOMEVX='FREQUENCE'
  344.       NOMEVY=ITITY(N0)
  345.       NUMEVX=ICOUL1
  346.       NUMEVY='REEL'
  347.       TI(1:72)=TITREE
  348.       IEVTEX=TI
  349.       ITYEVO='REEL'
  350. c       KEVTEX=TI
  351.       KEVTEX=NOMEVY
  352.       SEGDES KEVOLL
  353.       SEGDES MLREE2
  354.   100 CONTINUE
  355.       SEGDES MEVOLL
  356.       SEGDES MLREE1
  357.       SEGDES MLREEL
  358. c
  359. c
  360.       CALL ECROBJ ('EVOLUTIO',IPOEVO)
  361.       RETURN
  362.       END
  363.  
  364.  
  365.  
  366.  
  367.  
  368.  
  369.  
  370.  
  371.  
  372.  
  373.  
  374.  
  375.  
  376.  
  377.  
  378.  

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