Télécharger chsp.eso

Retour à la liste

Numérotation des lignes :

  1. C CHSP SOURCE BP208322 16/11/18 21:15:34 9177
  2. SUBROUTINE CHSP
  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 CONVERSION DE SPECTRE D'OSCILLATEUR EN DEPLACEMENT,VITESSE OU
  10. C
  11. C ACCELERATION.
  12. C
  13. C SYNTAXE : EVOL2 = CHSP EVOL1 ENTR ENTREE SORT SORTIE COUL COOL
  14. C
  15. C CREATION : 22/06/87
  16. C PROGRAMMEUR : MALAVAL
  17. C
  18. C ==================================================================
  19. C
  20. -INC CCOPTIO
  21. -INC SMEVOLL
  22. -INC CCREEL
  23. -INC CCGEOME
  24. -INC SMLREEL
  25.  
  26. CHARACTER*4 MODOM(3),MODON(3)
  27. CHARACTER*4 ITITY(3)
  28. DATA MODOM/'ENTR','SORT','COUL'/
  29. DATA MODON/'DEPL','VITE','ACCE'/
  30. DATA ITITY/'DEPL','VITE','ACCE'/
  31. LMOT=3
  32. ICOUL1=IDCOUL
  33. C
  34. C LECTURE DES MOTS
  35. C
  36. DO 10 I=1,3
  37. CALL LIRMOT (MODOM,LMOT,IPLAC,0)
  38. IF (IPLAC.EQ.0) GOTO 10
  39. GOTO (1,2,3),IPLAC
  40. C
  41. 1 CONTINUE
  42. C
  43. C SPECTRE EN ENTREE
  44. C
  45. CALL LIRMOT (MODON,3,IVAE,1)
  46. GOTO 10
  47. C
  48. 2 CONTINUE
  49. C
  50. C SPECTRE DE SORTIE
  51. C
  52. CALL LIRMOT (MODON,3,IVAS,1)
  53. GOTO 10
  54. C
  55. 3 CONTINUE
  56. C
  57. C COULEURS
  58. CALL LIRMOT (NCOUL,NBCOUL,ICOUL1,0)
  59. IF (ICOUL1.EQ.0) ICOUL1=IDCOUL+1
  60. ICOUL1=ICOUL1-1
  61. GOTO 10
  62. C
  63. 10 CONTINUE
  64. IF (IVAE.EQ.IVAS) CALL ERREUR (202)
  65. IF (IVAE*IVAS.EQ.0) CALL ERREUR (26)
  66. C
  67. C LECTURE DE L'OBJET EVOLUTION
  68. C
  69. CALL LIROBJ ('EVOLUTIO',IPOEVO,1,IRET)
  70. MEVOL1=IPOEVO
  71. SEGACT MEVOL1
  72. NEVO=MEVOL1.IEVOLL(/1)
  73. N=NEVO
  74. SEGINI MEVOLL
  75. IPOEVO=MEVOLL
  76. DO 88 K=1,NEVO
  77. KEVOL1=MEVOL1.IEVOLL(K)
  78. SEGACT KEVOL1
  79. IPFREQ=KEVOL1.IPROGX
  80. IPSPO=KEVOL1.IPROGY
  81. SEGDES KEVOL1
  82. C
  83. MLREEL=IPFREQ
  84. SEGACT MLREEL
  85. NN=MLREEL.PROG(/1)
  86. MLREE1=IPSPO
  87. SEGACT MLREE1
  88. JG=NN
  89. SEGINI MLREE2
  90. IPRES=MLREE2
  91. DO 15 I=1,NN
  92. W=2*XPI*PROG(I)
  93. C
  94. C EXAMEN DES DIFFERENTS CAS POSSIBLES
  95. C
  96. IF (IVAE.EQ.1) THEN
  97. IF (IVAS.EQ.2) THEN
  98. N0=2
  99. MLREE2.PROG(I)=W*MLREE1.PROG(I)
  100. ELSE
  101. N0=3
  102. W2=W*W
  103. MLREE2.PROG(I)=W2*MLREE1.PROG(I)
  104. ENDIF
  105. ENDIF
  106. C
  107. IF (IVAE.EQ.2) THEN
  108. IF (IVAS.EQ.1) THEN
  109. N0=1
  110. MLREE2.PROG(I)=MLREE1.PROG(I)/W
  111. ELSE
  112. N0=3
  113. MLREE2.PROG(I)=W*MLREE1.PROG(I)
  114. ENDIF
  115. ENDIF
  116. IF (IVAE.EQ.3) THEN
  117. IF (IVAS.EQ.2) THEN
  118. N0=2
  119. MLREE2.PROG(I)=MLREE1.PROG(I)/W
  120. ELSE
  121. N0=1
  122. W2=W*W
  123. MLREE2.PROG(I)=MLREE1.PROG(I)/W2
  124. ENDIF
  125. ENDIF
  126. 15 CONTINUE
  127. C
  128. SEGINI KEVOLL
  129. IEVOLL(K)=KEVOLL
  130. IPROGX=IPFREQ
  131. IPROGY=IPRES
  132. NOMEVX='FREQUENCE'
  133. NOMEVY=ITITY(N0)
  134. NUMEVX=ICOUL1
  135. NUMEVY='REEL'
  136. TYPX='LISTREEL'
  137. TYPY='LISTREEL'
  138. TI(1:72)=TITREE
  139. IEVTEX=TI
  140. KEVTEX=TI
  141. 25 CONTINUE
  142. SEGDES KEVOLL
  143. SEGDES MLREE2
  144. SEGDES MLREEL
  145. SEGDES MLREE1
  146. 88 CONTINUE
  147. SEGDES MEVOLL
  148. SEGDES MEVOL1
  149.  
  150. CALL ECROBJ ('EVOLUTIO',IPOEVO)
  151. RETURN
  152. END
  153.  
  154.  
  155.  
  156.  
  157.  
  158.  
  159.  
  160.  
  161.  
  162.  
  163.  
  164.  
  165.  

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