Télécharger psrs.eso

Retour à la liste

Numérotation des lignes :

  1. C PSRS SOURCE BP208322 16/11/18 21:20:34 9177
  2. C PSRS SOURCE ISPRA 90/02/27
  3. SUBROUTINE PSRS
  4. IMPLICIT INTEGER(I-N)
  5. IMPLICIT REAL*8(A-H,O-Z)
  6. C=======================================================================
  7. C = CALCUL DU "RESPONSE SPECTRUM" A PARTIR DU "POWER SPECTRUM" =
  8. C = POUR PLUSIEURS AMORTISSEMENTS =
  9. C = =
  10. C = SYNTAXE : =
  11. C = =
  12. C = RSPE*EVOL = PSRS PSPE*EVOL TE *REEL AMOR*LISTREEL =
  13. C = (TT*LISTREEL MCL1*MOT MCL2*MOT =
  14. C = MCL3*MOT COUL*MOT ) =
  15. C = =
  16. C = =
  17. C = RSPE : OBJET DE TYPE EVOLUTIO CONTENANT LES =
  18. C = "RESPONSE SPECTRA" (NAMOR COURBES) =
  19. C = PSPE : OBJET DE TYPE EVOLUTIO CONTENANT LE "POWER SPECTRUM"=
  20. C = ( UNE COURBE SEULEMENT ) =
  21. C = TE : REEL DONNANT LA DUREE DU SIGNAL (SEC.) =
  22. C = AMOR : OBJET DE TYPE LISTREEL CONTENANT NAMOR AMORTISSEMENTS
  23. C = =
  24. C = MCL1 : GRANDEUR DE REPONSE: 'DEPL(ACEMENT)', 'VITE(SSE)' =
  25. C = : OU 'ACCE(LERATION)' (DEFAUT) =
  26. C = MCL2 : DISTRIBUTION: 'NEWG(UMG)' OU 'CRAM(ER)' =
  27. C = MCL3 : CHOIX DE L'ABSISSE DU "RESPONSE SPECTRUM" =
  28. C = : 'FREQ(UENCE)' OU 'PERI(ODE)' (DEFAUT) =
  29. C = : DANS LES 2 CAS LES VALEURS SONT RANGEES PAR VALEURS =
  30. C = CROISSANTES DES ABSCISSES (UTILATION DE IPOL!) =
  31. C = TT : OBJET DE TYPE LISTREEL CONTENANT LES PERIODES =
  32. C = COUL : COULEUR ATTRIBUEE A L'OBJET CREE (FACULTATIF) =
  33. C = ( DEFAUT = COULEUR DE PSRS) =
  34. C = =
  35. C = CREATION : 27/02/90, reprise 2/4/90 =
  36. C = MESSAGE D'ERREUR : 15/9/91 =
  37. C = PROGRAMMEUR : A.P. ET P.P. =
  38. C=======================================================================
  39. C
  40. CHARACTER *72 TI
  41. CHARACTER*12 MOTX,MOTY
  42. C
  43. PARAMETER (NMOCLE=7)
  44. CHARACTER*4 MOTCLE(NMOCLE)
  45. LOGICAL LPERIO,LUSER
  46. C
  47. -INC CCGEOME
  48. -INC CCOPTIO
  49. -INC SMEVOLL
  50. -INC SMLREEL
  51. C
  52. SEGMENT MTRAV
  53. IMPLIED F(NSPT),S(NSPT) ,ETI(NAMRT), T(NI), RES(NAMRT,NI)
  54. ENDSEGMENT
  55. C
  56. DATA MOTCLE/'PERI','FREQ','ACCE','VITE','DEPL','CRAM','NEWG'/
  57. C
  58. C DEFAUT MCLE: "'PERI'->LPERIO, 'ACCE'->IGRAND, 'CRAM'->IDISTR
  59. C
  60. LPERIO=.TRUE.
  61. IGRAND=1
  62. IDISTR=1
  63. C
  64. C
  65. C LECTURE DE L'OBJET EVOLUTIO CONTENANT LE "POWER SPECTRUM"
  66. C
  67. CALL LIROBJ('EVOLUTIO',IPSIG,1,IRET1)
  68. IF(IRET1.EQ.0) GOTO 666
  69. C
  70. C LECTURE DU REEL DONNANT LA DUREE DU SIGNAL
  71. C
  72. CALL LIRREE(TE,1,IRET3)
  73. IF(IRET3.EQ.0) GOTO 666
  74. C
  75. C LECTURE DE L'OBJET LISTREEL CONTENANT LES AMORTISSEMENT
  76. C
  77. CALL LIROBJ('LISTREEL',IPREE,1,IRET2)
  78. IF(IRET2.EQ.0) GOTO 666
  79. C
  80. C LECTURE DE L'OBJET LISTREEL DONNANT LE TABLEAU DES PERIODES
  81. C DEFINI PAR L'UTILISATEUR
  82. C
  83. CALL LIROBJ('LISTREEL',IPREET,0,IRET4)
  84. IF(IRET4.EQ.0)THEN
  85. LUSER=.FALSE.
  86. ELSE
  87. LUSER=.TRUE.
  88. ENDIF
  89. C
  90. C LECTURE DES MOTS MCL1, MCL2, MCL3 ...ET DE LA COULEUR
  91. C
  92. * 1 CALL LIRMO2(MOTCLE,NMOCLE,IVAL,
  93. * > NCOUL ,NBCOUL,ICOUL,0)
  94. C
  95. 1 CALL LIRMOT(MOTCLE,NMOCLE,IVAL,0)
  96. * WRITE(*,*) MOTCLE
  97. CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0)
  98. * WRITE(*,*) NCOUL
  99. * WRITE(*,*) NBCOUL
  100. * WRITE(*,*) ICOUL
  101. IF (ICOUL.EQ.0) ICOUL=IDCOUL+1
  102. ICOUL=ICOUL-1
  103. IF(IVAL.EQ.0)GOTO 9
  104. GOTO(2,3,4,4,4,5,5),IVAL
  105. C ---> "MCL3"
  106. 2 LPERIO=.TRUE.
  107. WRITE(*,*) 'Dans 2'
  108. GOTO 1
  109. 3 LPERIO=.FALSE.
  110. WRITE(*,*) 'Dans 3'
  111. GOTO 1
  112. C ---> "MCL1" 1->ACCE, 2->VITE, 3->DEPL
  113. 4 IGRAND=IVAL-2
  114. WRITE(*,*) 'Dans 4'
  115. GOTO 1
  116. C ---> "MCL2" 1->CRAM, 2->NEWG
  117. 5 IDISTR=IVAL-5
  118. WRITE(*,*) 'Dans 5'
  119. GOTO 1
  120. C
  121. C LECTURE DE LA COULEUR
  122. C
  123. 9 IF(ICOUL.NE.0)GOTO 1
  124. C
  125. IF(IERR.NE.0) GOTO 666
  126. C
  127. C RECHERCHE DE LA TAILLE DU SEGMENT DE TRAVAIL
  128. C
  129. MEVOL1=IPSIG
  130. SEGACT MEVOL1
  131. KEVOL1=MEVOL1.IEVOLL(1)
  132. SEGACT KEVOL1
  133. C
  134. IF(ICOUL.EQ.0) ICOUL=KEVOL1.NUMEVX
  135. C
  136. MLREE3=KEVOL1.IPROGX
  137. SEGACT MLREE3
  138. NSPT=MLREE3.PROG(/1)
  139. SEGDES MLREE3
  140. C
  141. MLREE3=IPREE
  142. SEGACT MLREE3
  143. NAMRT=MLREE3.PROG(/1)
  144. SEGDES MLREE3
  145. C
  146. IF (LUSER)THEN
  147. MLREE3=IPREET
  148. SEGACT MLREE3
  149. NI=MLREE3.PROG(/1)
  150. SEGDES MLREE3
  151. NT=NI
  152. ELSE
  153. NI=75
  154. NT=0
  155. ENDIF
  156. C
  157. C CHARGEMENT DES TABLEAUX DE TRAVAIL
  158. C
  159. SEGINI MTRAV
  160. C
  161. MLREE1=KEVOL1.IPROGX
  162. MLREE2=KEVOL1.IPROGY
  163. SEGACT MLREE1,MLREE2
  164. DO 10 I=1,NSPT
  165. F(I)=MLREE1.PROG(I)
  166. S(I)=MLREE2.PROG(I)
  167. 10 CONTINUE
  168. SEGDES MLREE1
  169. SEGDES MLREE2
  170. SEGDES KEVOL1
  171. SEGDES MEVOL1
  172. C
  173. MLREE3=IPREE
  174. SEGACT MLREE3
  175. DO 11 I=1,NAMRT
  176. ETI(I)=MLREE3.PROG(I)
  177. 11 CONTINUE
  178. SEGDES MLREE3
  179. C
  180. IF (LUSER)THEN
  181. MLREE3=IPREET
  182. SEGACT MLREE3
  183. DO 12 I=1,NI
  184. T(I)=MLREE3.PROG(I)
  185. 12 CONTINUE
  186. SEGDES MLREE3
  187. ENDIF
  188. C
  189. C CALCUL DU "RESPONSE SPECTRUM"
  190. C
  191. CALL POSPRE(MTRAV,NSPT,NAMRT, IGRAND,IDISTR,TE,NT)
  192. IF(IIMPI.EQ.1) WRITE(IOIMP,*)' CALCUL DU "RESPONSE SPECTRUM" '
  193. C
  194. C ABSISSE EN PERIODE OU EN FREQUENCE
  195. C
  196. IF(LPERIO.AND.LUSER)THEN
  197. MLREE1=IPREET
  198. MOTX='PERIODE'
  199. ELSE
  200. JG=NT
  201. SEGINI MLREE1
  202. IF(LPERIO)THEN
  203. DO 20 I=1,NT
  204. MLREE1.PROG(I)=T(I)
  205. 20 CONTINUE
  206. MOTX='PERIODE'
  207. ELSE
  208. DO 21 I=1,NT
  209. MLREE1.PROG(NT-I+1)=1/T(I)
  210. 21 CONTINUE
  211. MOTX='FREQUENCE'
  212. ENDIF
  213. SEGDES MLREE1
  214. ENDIF
  215. C
  216. C LEGENDE (PARTIELLE) DES ORDONNEES
  217. C
  218. MOTY(1:10)='RSPE-'//MOTCLE(2+IGRAND)//' '
  219. C
  220. C CREATION DE L'OBJET EVOLUTIO RSPE
  221. C
  222. N=NAMRT
  223. SEGINI MEVOLL
  224. IPVO=MEVOLL
  225. TI(1:72)=TITREE
  226. IEVTEX=TI
  227. ITYEVO='REEL'
  228. C
  229. DO 30 IEVOL=1,NAMRT
  230. C
  231. SEGINI KEVOLL
  232. C
  233. WRITE(TI,100)ETI(IEVOL)
  234. 100 FORMAT(1X,'AMORTISSEMENT DE ',1PD12.5)
  235. KEVTEX=TI
  236. C
  237. IEVOLL(IEVOL)=KEVOLL
  238. TYPX='LISTREEL'
  239. TYPY='LISTREEL'
  240. C
  241. IPROGX=MLREE1
  242. NOMEVX=MOTX(1:12)
  243. C
  244. JG=NT
  245. SEGINI MLREE2
  246. IF(LPERIO)THEN
  247. DO 22 I=1,NT
  248. MLREE2.PROG(I)=RES(IEVOL,I)
  249. 22 CONTINUE
  250. ELSE
  251. DO 23 I=1,NT
  252. MLREE2.PROG(NT-I+1)=RES(IEVOL,I)
  253. 23 CONTINUE
  254. ENDIF
  255. SEGDES MLREE2
  256. IPROGY=MLREE2
  257. WRITE(MOTY(11:12),'(I2)')IEVOL
  258. NOMEVY=MOTY(1:12)
  259. C
  260. NUMEVX=ICOUL
  261. NUMEVY='REEL'
  262. C
  263. SEGDES KEVOLL
  264. 30 CONTINUE
  265. C
  266. SEGDES MEVOLL
  267. SEGSUP MTRAV
  268. C
  269. CALL ECROBJ('EVOLUTIO',IPVO)
  270. 666 CONTINUE
  271. RETURN
  272. END
  273.  
  274.  
  275.  
  276.  
  277.  
  278.  
  279.  
  280.  
  281.  
  282.  
  283.  
  284.  

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