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.  
  49. -INC PPARAM
  50. -INC CCOPTIO
  51. -INC SMEVOLL
  52. -INC SMLREEL
  53. C
  54. SEGMENT MTRAV
  55. IMPLIED F(NSPT),S(NSPT) ,ETI(NAMRT), T(NI), RES(NAMRT,NI)
  56. ENDSEGMENT
  57. C
  58. DATA MOTCLE/'PERI','FREQ','ACCE','VITE','DEPL','CRAM','NEWG'/
  59. C
  60. C DEFAUT MCLE: "'PERI'->LPERIO, 'ACCE'->IGRAND, 'CRAM'->IDISTR
  61. C
  62. LPERIO=.TRUE.
  63. IGRAND=1
  64. IDISTR=1
  65. C
  66. C
  67. C LECTURE DE L'OBJET EVOLUTIO CONTENANT LE "POWER SPECTRUM"
  68. C
  69. CALL LIROBJ('EVOLUTIO',IPSIG,1,IRET1)
  70. IF(IRET1.EQ.0) GOTO 666
  71. C
  72. C LECTURE DU REEL DONNANT LA DUREE DU SIGNAL
  73. C
  74. CALL LIRREE(TE,1,IRET3)
  75. IF(IRET3.EQ.0) GOTO 666
  76. C
  77. C LECTURE DE L'OBJET LISTREEL CONTENANT LES AMORTISSEMENT
  78. C
  79. CALL LIROBJ('LISTREEL',IPREE,1,IRET2)
  80. IF(IRET2.EQ.0) GOTO 666
  81. C
  82. C LECTURE DE L'OBJET LISTREEL DONNANT LE TABLEAU DES PERIODES
  83. C DEFINI PAR L'UTILISATEUR
  84. C
  85. CALL LIROBJ('LISTREEL',IPREET,0,IRET4)
  86. IF(IRET4.EQ.0)THEN
  87. LUSER=.FALSE.
  88. ELSE
  89. LUSER=.TRUE.
  90. ENDIF
  91. C
  92. C LECTURE DES MOTS MCL1, MCL2, MCL3 ...ET DE LA COULEUR
  93. C
  94. * 1 CALL LIRMO2(MOTCLE,NMOCLE,IVAL,
  95. * > NCOUL ,NBCOUL,ICOUL,0)
  96. C
  97. 1 CALL LIRMOT(MOTCLE,NMOCLE,IVAL,0)
  98. * WRITE(*,*) MOTCLE
  99. CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0)
  100. * WRITE(*,*) NCOUL
  101. * WRITE(*,*) NBCOUL
  102. * WRITE(*,*) ICOUL
  103. IF (ICOUL.EQ.0) ICOUL=IDCOUL+1
  104. ICOUL=ICOUL-1
  105. IF(IVAL.EQ.0)GOTO 9
  106. GOTO(2,3,4,4,4,5,5),IVAL
  107. C ---> "MCL3"
  108. 2 LPERIO=.TRUE.
  109. WRITE(*,*) 'Dans 2'
  110. GOTO 1
  111. 3 LPERIO=.FALSE.
  112. WRITE(*,*) 'Dans 3'
  113. GOTO 1
  114. C ---> "MCL1" 1->ACCE, 2->VITE, 3->DEPL
  115. 4 IGRAND=IVAL-2
  116. WRITE(*,*) 'Dans 4'
  117. GOTO 1
  118. C ---> "MCL2" 1->CRAM, 2->NEWG
  119. 5 IDISTR=IVAL-5
  120. WRITE(*,*) 'Dans 5'
  121. GOTO 1
  122. C
  123. C LECTURE DE LA COULEUR
  124. C
  125. 9 IF(ICOUL.NE.0)GOTO 1
  126. C
  127. IF(IERR.NE.0) GOTO 666
  128. C
  129. C RECHERCHE DE LA TAILLE DU SEGMENT DE TRAVAIL
  130. C
  131. MEVOL1=IPSIG
  132. SEGACT MEVOL1
  133. KEVOL1=MEVOL1.IEVOLL(1)
  134. SEGACT KEVOL1
  135. C
  136. IF(ICOUL.EQ.0) ICOUL=KEVOL1.NUMEVX
  137. C
  138. MLREE3=KEVOL1.IPROGX
  139. SEGACT MLREE3
  140. NSPT=MLREE3.PROG(/1)
  141. SEGDES MLREE3
  142. C
  143. MLREE3=IPREE
  144. SEGACT MLREE3
  145. NAMRT=MLREE3.PROG(/1)
  146. SEGDES MLREE3
  147. C
  148. IF (LUSER)THEN
  149. MLREE3=IPREET
  150. SEGACT MLREE3
  151. NI=MLREE3.PROG(/1)
  152. SEGDES MLREE3
  153. NT=NI
  154. ELSE
  155. NI=75
  156. NT=0
  157. ENDIF
  158. C
  159. C CHARGEMENT DES TABLEAUX DE TRAVAIL
  160. C
  161. SEGINI MTRAV
  162. C
  163. MLREE1=KEVOL1.IPROGX
  164. MLREE2=KEVOL1.IPROGY
  165. SEGACT MLREE1,MLREE2
  166. DO 10 I=1,NSPT
  167. F(I)=MLREE1.PROG(I)
  168. S(I)=MLREE2.PROG(I)
  169. 10 CONTINUE
  170. SEGDES MLREE1
  171. SEGDES MLREE2
  172. SEGDES KEVOL1
  173. SEGDES MEVOL1
  174. C
  175. MLREE3=IPREE
  176. SEGACT MLREE3
  177. DO 11 I=1,NAMRT
  178. ETI(I)=MLREE3.PROG(I)
  179. 11 CONTINUE
  180. SEGDES MLREE3
  181. C
  182. IF (LUSER)THEN
  183. MLREE3=IPREET
  184. SEGACT MLREE3
  185. DO 12 I=1,NI
  186. T(I)=MLREE3.PROG(I)
  187. 12 CONTINUE
  188. SEGDES MLREE3
  189. ENDIF
  190. C
  191. C CALCUL DU "RESPONSE SPECTRUM"
  192. C
  193. CALL POSPRE(MTRAV,NSPT,NAMRT, IGRAND,IDISTR,TE,NT)
  194. IF(IIMPI.EQ.1) WRITE(IOIMP,*)' CALCUL DU "RESPONSE SPECTRUM" '
  195. C
  196. C ABSISSE EN PERIODE OU EN FREQUENCE
  197. C
  198. IF(LPERIO.AND.LUSER)THEN
  199. MLREE1=IPREET
  200. MOTX='PERIODE'
  201. ELSE
  202. JG=NT
  203. SEGINI MLREE1
  204. IF(LPERIO)THEN
  205. DO 20 I=1,NT
  206. MLREE1.PROG(I)=T(I)
  207. 20 CONTINUE
  208. MOTX='PERIODE'
  209. ELSE
  210. DO 21 I=1,NT
  211. MLREE1.PROG(NT-I+1)=1/T(I)
  212. 21 CONTINUE
  213. MOTX='FREQUENCE'
  214. ENDIF
  215. SEGDES MLREE1
  216. ENDIF
  217. C
  218. C LEGENDE (PARTIELLE) DES ORDONNEES
  219. C
  220. MOTY(1:10)='RSPE-'//MOTCLE(2+IGRAND)//' '
  221. C
  222. C CREATION DE L'OBJET EVOLUTIO RSPE
  223. C
  224. N=NAMRT
  225. SEGINI MEVOLL
  226. IPVO=MEVOLL
  227. TI(1:72)=TITREE
  228. IEVTEX=TI
  229. ITYEVO='REEL'
  230. C
  231. DO 30 IEVOL=1,NAMRT
  232. C
  233. SEGINI KEVOLL
  234. C
  235. WRITE(TI,100)ETI(IEVOL)
  236. 100 FORMAT(1X,'AMORTISSEMENT DE ',1PD12.5)
  237. KEVTEX=TI
  238. C
  239. IEVOLL(IEVOL)=KEVOLL
  240. TYPX='LISTREEL'
  241. TYPY='LISTREEL'
  242. C
  243. IPROGX=MLREE1
  244. NOMEVX=MOTX(1:12)
  245. C
  246. JG=NT
  247. SEGINI MLREE2
  248. IF(LPERIO)THEN
  249. DO 22 I=1,NT
  250. MLREE2.PROG(I)=RES(IEVOL,I)
  251. 22 CONTINUE
  252. ELSE
  253. DO 23 I=1,NT
  254. MLREE2.PROG(NT-I+1)=RES(IEVOL,I)
  255. 23 CONTINUE
  256. ENDIF
  257. SEGDES MLREE2
  258. IPROGY=MLREE2
  259. WRITE(MOTY(11:12),'(I2)')IEVOL
  260. NOMEVY=MOTY(1:12)
  261. C
  262. NUMEVX=ICOUL
  263. NUMEVY='REEL'
  264. C
  265. SEGDES KEVOLL
  266. 30 CONTINUE
  267. C
  268. SEGDES MEVOLL
  269. SEGSUP MTRAV
  270. C
  271. CALL ECROBJ('EVOLUTIO',IPVO)
  272. 666 CONTINUE
  273. RETURN
  274. END
  275.  
  276.  
  277.  
  278.  
  279.  
  280.  
  281.  
  282.  
  283.  
  284.  
  285.  
  286.  

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