Télécharger chsp.eso

Retour à la liste

Numérotation des lignes :

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

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