Télécharger prns.eso

Retour à la liste

Numérotation des lignes :

  1. C PRNS SOURCE BP208322 16/11/18 21:20:13 9177
  2. C PRNS SOURCE ISPRA 90/05/03
  3. SUBROUTINE PRNS
  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 = DANS LE CAS NON STATIONNAIRE =
  9. C = =
  10. C = SYNTAXE : =
  11. C = =
  12. C = RSNS*EVOL = PRNS PSNS*EVOL =
  13. C = M *EVOL FREQ*LISTREEL =
  14. C = (TT*LISTREEL AMOR*FLOTTANT =
  15. C = MCL1*MOT MCL2*MOT MCL3*MOT =
  16. C = COUL*MOT =
  17. C = MCL4*MOT NUM*ENTIER =
  18. C = MCL5*MOT DTBASE*FLOTTANT ) =
  19. C = =
  20. C = =
  21. C = RSNS : OBJET DE TYPE EVOLUTIO CONTENANT LES =
  22. C = "RESPONSE SPECTRA" (1 COURBE) =
  23. C = =
  24. C = PSPE : OBJET DE TYPE EVOLUTIO CONTENANT LE "POWER SPECTRUM"=
  25. C = ( UNE COURBE SEULEMENT ) =
  26. C = =
  27. C = M : OBJET DE TYPE EVOLUTIO CONTENANT N COURBES =
  28. C = D'EVOLUTIONS TEMPORELLE (LES TEMPS FINALS DOIVENT =
  29. C = ETRE IDENTIQUES) =
  30. C = =
  31. C = FREQ : OBJET DE TYPE LISTREEL CONTENANT N+1 FREQUENCES =
  32. C = (FREQ"(I)" ET FREQ"(I+1)" DEFINISSENT LA BANDE DE =
  33. C = VALIDITE DE M"(I)") =
  34. C = =
  35. C = TT : OBJET DE TYPE LISTREEL CONTENANT LES PERIODES =
  36. C = AMOR : OBJET DE TYPE FLOTTANT CONTENANT L'AMORTISSEMENT =
  37. C = MCL1 : GRANDEUR DE REPONSE: 'DEPL(ACEMENT)', 'VITE(SSE)' =
  38. C = OU 'ACCE(LERATION)' (DEFAUT) =
  39. C = MCL2 : CHOIX DE L'ABSISSE DU "RESPONSE SPECTRUM" =
  40. C = 'FREQ(UENCE)' OU 'PERI(ODE)' (DEFAUT) =
  41. C = DANS LES 2 CAS LES VALEURS SONT RANGEES PAR VALEURS =
  42. C = CROISSANTES DES ABSCISSES (UTILATION DE IPOL!) =
  43. C = MCL3 : CHOIX DE LA DISTRIBUTION: 'NEG1' =
  44. C = OU 'NEG2' (DEFAUT) =
  45. C = COUL : COULEUR ATTRIBUEE A L'OBJET CREE (FACULTATIF) =
  46. C = ( DEFAUT = COULEUR DE PSNL) =
  47. C = MCL4 : INTEGRATION NEWMARK: =
  48. C = 'NBPR(OCESSUS)' + NUM = NB PROCESSUS STATIONAIRES =
  49. C = 'NBIN(TEGRATION)'+ NUM = NB PTS D'INTEGRATION EN T =
  50. C = 'PREC(ISION)'+ ERR = ERREUR PROC. ITERATIFS =
  51. C = 'TPLU(S)' + TPL = TEMPS EN PLUS =
  52. C = 'NBDE(FAUT)' = VALEURS PAR DEFAUT =
  53. C = MCL5 : CALCUL PAR ONDELETTE =
  54. C = 'ONDE' AVEC FCT DE MODULATION CLASSIQUE =
  55. C = OU AVEC COEFF EN ONDELETTE =
  56. C = =
  57. C = CREATION : creation 3/5/90 =
  58. C = MODIF ONDEL : 24/9/90 =
  59. C = DPI NON EGAL A 8*TAN(1.) !!!!: 24/1/91 =
  60. C = AJOUT DE 20 S A LA DUREE : 29/1/91 =
  61. C = MESSAGE D'ERREUR : 15/9/91 =
  62. C = PROGRAMMEUR : P.P. =
  63. C=======================================================================
  64. C
  65. CHARACTER *72 TI
  66. CHARACTER*12 MOTX,MOTY
  67. C
  68. PARAMETER (NMOCLE=13)
  69. CHARACTER*4 MOTCLE(NMOCLE)
  70. LOGICAL LPERIO,LUSER
  71. LOGICAL LONDEL
  72. C
  73. -INC CCGEOME
  74.  
  75. -INC PPARAM
  76. -INC CCOPTIO
  77. -INC SMEVOLL
  78. -INC SMLREEL
  79. POINTEUR MLREK2.MLREEL
  80. C
  81. DIMENSION XLTI(3)
  82. SEGMENT MTRAV
  83. INTEGER IFREQ(2,NBFREQ)
  84. REAL*8 F(NSPTOM),S(NSPTOM), T(NT), RES(NT)
  85. REAL*8 XLSTAT(3,NBFREQ)
  86. REAL*8 XMTK2(NBFREQ,IPROC)
  87. C REAL*8 XLTIME(NTIME,3)
  88. ENDSEGMENT
  89. C======+++++++++++ bon fontionnement erreur PSRS/PRNS +++++++++++ ======
  90. SEGMENT,MMTRA
  91. REAL*8 XLTIME(NNT,3)
  92. ENDSEGMENT
  93. C======+++++++++++ bon fontionnement erreur PSRS/PRNS +++++++++++ ======
  94. SEGMENT MONDE
  95. REAL*8 XPAS(NBFREQ)
  96. c* POINTEUR IMTK2(NBFREQ).MLREEL
  97. INTEGER IMTK2(NBFREQ)
  98. ENDSEGMENT
  99. C
  100. C 1) LECTURE DES DONNEES GIBIANE
  101. C
  102. C 1.1) LISTE DES MOTS CLEF
  103. C
  104. DATA MOTCLE/'PERI','FREQ','ACCE','VITE','DEPL',
  105. > 'NBDE','NBPR','NBIN','PREC','NEG1','NEG2',
  106. > 'ONDE','TPLU'/
  107. C
  108. C 1.2) DEFAUTS
  109. C (MCLE: "'PERI'->LPERIO, 'ACCE'->IGRAND, 'NEWG'->IDISTR)
  110. C
  111. LPERIO=.TRUE.
  112. IGRAND=1
  113. IDISTR=2
  114. C
  115. IPROC=0
  116. IINT=0
  117. AMOR=0.05D0
  118. XRREUR=1.D-3
  119. TPL=20.D0
  120. C
  121. LONDEL=.FALSE.
  122. C
  123. C 1.3) LECTURE DE L'OBJET EVOLUTIO CONTENANT LE "POWER SPECTRUM"
  124. C
  125. CALL LIROBJ('EVOLUTIO',IPPS,1,IRET)
  126. IF(IRET.EQ.0) GOTO 666
  127. C
  128. C 1.4) LECTURE DE L'OBJET EVOLUTIO CONTENANT LES FONCTIONS DE MODULATIONS
  129. C
  130. CALL LIROBJ('EVOLUTIO',IPMOD,1,IRET)
  131. IF(IRET.EQ.0) GOTO 666
  132. C
  133. C 1.5) LECTURE DE L'OBJET LISTREEL CONTENANT LES FREQUENCES
  134. C
  135. CALL LIROBJ('LISTREEL',IPFRE,1,IRET)
  136. IF(IRET.EQ.0) GOTO 666
  137. C
  138. C 1.6) LECTURE DE L'OBJET LISTREEL DONNANT LE TABLEAU DES PERIODES
  139. C DEFINI PAR L'UTILISATEUR (OPTIONEL)
  140. C
  141. CALL LIROBJ('LISTREEL',IPREET,0,IRET)
  142. IF(IRET.EQ.0)THEN
  143. LUSER=.FALSE.
  144. ELSE
  145. LUSER=.TRUE.
  146. ENDIF
  147. C
  148. C 1.7) LECTURE DU REEL DONNANT L'AMORTISSEMENT (OPTIONEL)
  149. C
  150. CALL LIRREE(AMOR1,0,IRET)
  151. IF(IRET.NE.0)THEN
  152. ENDIF
  153. C
  154. C 1.8) LECTURE DES MOTS MCL1, MCL2, MCL3, MCL4 ...ET DE LA COULEUR
  155. C (OPTIONEL)
  156. C
  157. * 1 CALL LIRMO2(MOTCLE,NMOCLE,IVAL,
  158. * > NCOUL ,NBCOUL,ICOUL,0)
  159. C
  160. 1 CALL LIRMOT(MOTCLE,NMOCLE,IVAL,0)
  161. CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0)
  162. if (icoul.eq.0) icoul=idcoul+1
  163. icoul=icoul-1
  164. C
  165. IF(IVAL.EQ.0)GOTO 9
  166. GOTO(2,3,4,4,4,1,5,6,7,8,8,881,882),IVAL
  167. C ---> "MCL2"
  168. 2 LPERIO=.TRUE.
  169. GOTO 1
  170. 3 LPERIO=.FALSE.
  171. GOTO 1
  172. C ---> "MCL1" 1->ACCE, 2->VITE, 3->DEPL
  173. 4 IGRAND=IVAL-2
  174. GOTO 1
  175. C ---> "MCL4" 1->NBDE, 2->NBPR, 3->NBIN
  176. 5 CALL LIRENT(IPROC,1,IRET)
  177. IF(IRET.EQ.0) GOTO 666
  178. GOTO 1
  179. 6 CALL LIRENT(IINT,1,IRET)
  180. IF(IRET.EQ.0) GOTO 666
  181. GOTO 1
  182. 7 CALL LIRREE(XRREUR,1,IRET)
  183. IF(IRET.EQ.0) GOTO 666
  184. GOTO 1
  185. C ---> "MCL3" 1->NEG1, 2->NEG2
  186. 8 IDISTR=IVAL-9
  187. GOTO 1
  188. C ---> "MCL5" ONDELETTE...
  189. 881 LONDEL=.TRUE.
  190. CALL LIRREE(DTBASE,1,IRET)
  191. IF(IRET.EQ.0) GOTO 666
  192. GOTO 1
  193. C ---> "MCL4" 4->TPL
  194. 882 CALL LIRREE(TPL,1,IRET)
  195. IF(IRET.EQ.0) GOTO 666
  196. GOTO 1
  197. C
  198. C 1.9) "LECTURE" DE LA COULEUR
  199. C
  200. 9 IF(ICOUL.NE.0)GOTO 1
  201. C
  202. IF(IERR.NE.0) GOTO 666
  203. C WRITE(IOIMP,*)'FIN LECTURE'
  204. C
  205. C 2) VERIFICATION DE LA COHERENCE DES DONNEES M, FREQ ET PSNS
  206. C
  207. C 2.1) NB DE COURBE/NB D'INTERVALLE DE FREQUENCE
  208. C
  209. MEVOL2=IPMOD
  210. SEGACT MEVOL2
  211. NBFREQ=MEVOL2.IEVOLL(/1)
  212.  
  213. MLREE3=IPFRE
  214. SEGACT MLREE3
  215. NBFRE1=MLREE3.PROG(/1) -1
  216.  
  217. IF(NBFREQ.NE.NBFRE1)THEN
  218. CALL ERREUR(578)
  219. GOTO 665
  220. ENDIF
  221. C
  222. C 2.2) DEBUT ET FIN DES FONCTIONS DE MODULATION
  223. C
  224. KEVOLL=MEVOL2.IEVOLL(1)
  225. SEGACT KEVOLL
  226. MLREEL=IPROGX
  227. SEGACT MLREEL
  228. TINI=PROG(1)
  229. TFIN=PROG(PROG(/1))
  230. SEGDES MLREEL
  231. SEGDES KEVOLL
  232.  
  233. IF (NBFREQ.GT.1)THEN
  234. DO 10 IE1=2,NBFREQ
  235. KEVOLL=MEVOL2.IEVOLL(IE1)
  236. SEGACT KEVOLL
  237. MLREEL=IPROGX
  238. SEGACT MLREEL
  239. TINI1=PROG(1)
  240. TFIN1=PROG(PROG(/1))
  241. SEGDES MLREEL
  242. SEGDES KEVOLL
  243. IF((ABS(TINI-TINI1)+ABS(TFIN-TFIN1)).GT.1.D-5)THEN
  244. CALL ERREUR(579)
  245. GOTO 665
  246. ENDIF
  247. 10 CONTINUE
  248. ENDIF
  249. TE=TFIN-TINI
  250. C
  251. C 2.3) INTERVALLE DE FREQUENCE DU SPECTRE DE PUISSANCE
  252. C
  253. FRMI=MLREE3.PROG(1)
  254. FRMA=MLREE3.PROG(NBFREQ+1)
  255.  
  256. MEVOL1=IPPS
  257. SEGACT MEVOL1
  258. KEVOL1=MEVOL1.IEVOLL(1)
  259. SEGACT KEVOL1
  260. C
  261. IF(ICOUL.EQ.0) ICOUL=KEVOL1.NUMEVX
  262. C
  263. MLREE1=KEVOL1.IPROGX
  264. MLREE2=KEVOL1.IPROGY
  265. SEGACT MLREE1
  266. FRMI1=MLREE1.PROG(1)
  267. NBSPEC=MLREE1.PROG(/1)
  268. FRMA1=MLREE1.PROG(NBSPEC)
  269. IF(.NOT.LONDEL)THEN
  270. IF ((ABS(FRMI-FRMI1)+ABS(FRMA-FRMA1)).GT.1.D-5)THEN
  271. CALL ERREUR(580)
  272. GOTO 664
  273. ENDIF
  274. ENDIF
  275. C
  276. C 2.4) VERIFICATION SPECIFIQUE DU CALCUL EN ONDELETTE
  277. C -NB DE BANDE DE FREQUENCE
  278. C -REPARTITION DES BANDES PAR OCTAVE
  279. C -DETERMINATION DU PAS DE TEMPS D'IDENTIFICATION
  280. C
  281. IF(LONDEL)THEN
  282. C
  283. IF(NBSPEC.NE.NBFREQ)THEN
  284. CALL ERREUR(581)
  285. GOTO 664
  286. ENDIF
  287. C
  288. FREQBA=MLREE3.PROG(2)
  289. FREQB=FREQBA
  290. DO 800 IE1=2,NBFREQ
  291. FFREQ=MLREE3.PROG(IE1+1)-MLREE3.PROG(IE1)
  292. IF (ABS(FFREQ-FREQB)/FREQB.GT.1.D-5)THEN
  293. CALL ERREUR(582)
  294. GOTO 664
  295. ENDIF
  296. FREQC=3*FREQB/2
  297. IF(ABS(MLREE1.PROG(IE1)-FREQC)/FREQC.GT.1.D-5)THEN
  298. CALL ERREUR(583)
  299. GOTO 664
  300. ENDIF
  301. FREQB=FREQB*2
  302. 800 CONTINUE
  303. C
  304. SEGINI, MONDE
  305. DDXMXP=0.D0
  306. DO 805 IE1=1,NBFREQ
  307. KEVOLL=MEVOL2.IEVOLL(IE1)
  308. SEGACT KEVOLL
  309. MLREEL=IPROGX
  310. SEGACT MLREEL
  311. DDXMAX=0.D0
  312. DO 801 IE2=2,PROG(/1)
  313. DDMMA=PROG(IE2)-PROG(IE2-1)
  314. IF(DDMMA.GT.DDXMAX)DDXMAX=DDMMA
  315. 801 CONTINUE
  316. ITE=INT(TE/DDXMAX+1.D-5)
  317. TTEST=TE-ITE*DDXMAX
  318. ITE=INT(DDXMXP/DDXMAX+1.D-5)
  319. TTEST=TTEST+DDXMXP-ITE*DDXMAX
  320. IF((ABS(TTEST).GT.2.D-5).OR.(ITE.GT.2))THEN
  321. INTERR(1)=IE1
  322. CALL ERREUR(584)
  323. DDXMAX=0.D0
  324. DO 802 IE2=2,PROG(/1)
  325. DDXMAX=DDXMAX+(PROG(IE2)-PROG(IE2-1))
  326. ITE=INT(TE/DDXMAX+1.D-5)
  327. TTEST=TE-ITE*DDXMAX
  328. ITE=INT(DDXMXP/DDXMAX+1.D-5)
  329. TTEST=TTEST+DDXMXP-ITE*DDXMAX
  330. IF((ABS(TTEST).LE.2.D-5).AND.(ITE.LE.2))GOTO 803
  331. 802 CONTINUE
  332. CALL ERREUR(485)
  333. GOTO 663
  334. 803 CONTINUE
  335. ENDIF
  336. XPAS(IE1)=DDXMAX
  337. DDXMXP=DDXMAX
  338. SEGDES MLREEL
  339. SEGDES KEVOLL
  340. 805 CONTINUE
  341. C
  342. ENDIF
  343. C WRITE(IOIMP,*)'FIN VERIFICATION DES DONNEES'
  344. C
  345. C 3) CALCUL DES BORNES DE LA ZONE DE TRAVAIL
  346. C
  347. C SPECTRE DE PUISSANCE + BORNE DE FREQUENCE
  348. C NOMBRE D'OSCILLATEUR POUR LA REPONSE
  349. C NOMBRE DE POINT D'EVALUATION EN TEMPS
  350. C
  351. NSPT=MLREE1.PROG(/1)
  352. NSPTOM=NSPT+NBFREQ-1
  353. C
  354. IF(LONDEL)NSPTOM=NSPTOM+1
  355. C
  356. IF (LUSER)THEN
  357. MLREEL=IPREET
  358. SEGACT MLREEL
  359. NT=PROG(/1)
  360. SEGDES MLREEL
  361. ELSE
  362. NT=75
  363. ENDIF
  364. C
  365. IF (IPROC.EQ.0)THEN
  366. IPROC=INT((TE-1.D-5)/2)+1
  367. ENDIF
  368. IF (IINT.EQ.0)THEN
  369. IINT=10
  370. ENDIF
  371. NTIME=IPROC*IINT+1
  372. IF(LONDEL)THEN
  373. NNTIME=INT(TE/XPAS(NBFREQ)+1.D-5)+1
  374. IF(NNTIME.LT.NTIME)THEN
  375. MMULT=INT(LOG(DBLE((NTIME-1)/(NNTIME-1)))/LOG(2.D0)+1.D-5)
  376. MMULT=2**MMULT
  377. NTIME=MMULT*(NNTIME-1)+1
  378. IPROC=1
  379. ELSE
  380. NTIME=NNTIME
  381. ENDIF
  382. ENDIF
  383. DTIME=TE/(NTIME-1)
  384. C
  385. NTIMEP=INT(TPL/DTIME +1.D-5)
  386. NTIME=NTIME+NTIMEP
  387. C WRITE(IOIMP,*)'FIN CALCUL DES BORNES DE LA ZONE DE TRAVAIL'
  388. C
  389. C 4) REMPLISSAGE DES TABLEAUX DE TRAVAIL
  390. C
  391. NNT=NTIME
  392. SEGINI,MTRAV,MMTRA
  393. C
  394. C 4.1) INDICE MIN/MAX DES BANDES DE FREQUENCE (ON PREVOIT D'INTERCALER
  395. C DES POINTS)
  396. C CALCUL DU NOMBRE DE POINT POUR F ET S
  397. C CHARGEMENT DES POINTS POUR F ET S
  398. C
  399. SEGACT MLREE2
  400. C
  401. IF(LONDEL)THEN
  402. C
  403. DO 810 IE1=1,NBFREQ
  404. IFREQ(1,IE1)=2*IE1-1
  405. IFREQ(2,IE1)=2*IE1
  406. F(2*IE1-1) =MLREE3.PROG(IE1)
  407. F(2*IE1 ) =MLREE3.PROG(IE1+1)
  408. S(2*IE1-1) =MLREE2.PROG(IE1)
  409. S(2*IE1 ) =MLREE2.PROG(IE1)
  410. 810 CONTINUE
  411. C
  412. ELSE
  413. C
  414. IFREQ(1,1)=1
  415. IF(NBFREQ.EQ.1)THEN
  416. IFREQ(2,1)=NSPT
  417. NSPTOT=NSPT
  418. DO 101 IE1=1,NSPTOT
  419. F(IE1)=MLREE1.PROG(IE1)
  420. S(IE1)=MLREE2.PROG(IE1)
  421. 101 CONTINUE
  422. ELSE
  423. IESP=2
  424. IPTSUP=0
  425. F(1)=MLREE1.PROG(1)
  426. S(1)=MLREE2.PROG(1)
  427. DO 13 IE1=2,NBFREQ
  428. FRM =MLREE3.PROG(IE1)
  429. DO 11 IE3=1,NSPT
  430. FRPS=MLREE1.PROG(IESP)
  431. IF(FRPS.GT.(FRM-1.D-5)) GOTO 12
  432. F(IESP+IPTSUP)=FRPS
  433. S(IESP+IPTSUP)=MLREE2.PROG(IESP)
  434. IESP=IESP+1
  435. 11 CONTINUE
  436. 12 IF(FRPS.GT.(FRM+1.D-5))THEN
  437. F(IESP+IPTSUP)=FRM
  438. S(IESP+IPTSUP)=MLREE2.PROG(IESP)
  439. > - (FRPS-FRM)/(FRPS-MLREE1.PROG(IESP-1))
  440. > *(MLREE2.PROG(IESP)-MLREE2.PROG(IESP-1))
  441. IFREQ(2,IE1-1)=IESP+IPTSUP
  442. IFREQ(1,IE1 )=IESP+IPTSUP
  443. IPTSUP=IPTSUP+1
  444. ELSE
  445. F(IESP+IPTSUP)=FRPS
  446. S(IESP+IPTSUP)=MLREE2.PROG(IESP)
  447. IFREQ(2,IE1-1)=IESP+IPTSUP
  448. IFREQ(1,IE1 )=IESP+IPTSUP
  449. IESP=IESP+1
  450. ENDIF
  451. 13 CONTINUE
  452. NSPTOT=NSPT+IPTSUP
  453. IFREQ(2,NBFREQ)=NSPTOT
  454. DO 14 IE1=IESP,NSPT
  455. F(IE1+IPTSUP)=MLREE1.PROG(IE1)
  456. S(IE1+IPTSUP)=MLREE2.PROG(IE1)
  457. 14 CONTINUE
  458. ENDIF
  459. C
  460. ENDIF
  461. C
  462. SEGDES MLREE1
  463. SEGDES MLREE2
  464. SEGDES MEVOL1
  465. SEGDES MLREE3
  466. C
  467. C 4.1-BIS) INDICE MIN, LARGEUR DE BANDE DANS IFREQ
  468. C
  469. DO 15 IE1=1,NBFREQ
  470. IFREQ(2,IE1)=IFREQ(2,IE1)-IFREQ(1,IE1) + 1
  471. 15 CONTINUE
  472. C
  473. C 4.2) ON REMPLIT LE TABLEAU DES PERIODES
  474. C
  475. IF (LUSER)THEN
  476. MLREEL=IPREET
  477. SEGACT MLREEL
  478. DO 20 I=1,NT
  479. T(I)=PROG(I)
  480. 20 CONTINUE
  481. SEGDES MLREEL
  482. ELSE
  483. TINF=.04D0
  484. UNPXI=EXP((LOG(TE)-LOG(TINF))/(NT-1))
  485. T(1)=TINF
  486. DO 21 I=2,NT
  487. 21 T(I)=T(I-1)*UNPXI
  488. T(NT)=TE
  489. ENDIF
  490. C
  491. C 4.3) ON REMPLIT XLTIME (INTERPOLATION DES MK A TR)
  492. C
  493. IF(LONDEL)THEN
  494. C
  495. DDT=DTBASE
  496. DO 817 IE1=1,NBFREQ
  497. KEVOLL=MEVOL2.IEVOLL(IE1)
  498. SEGACT, KEVOLL
  499. MLREE1=IPROGX
  500. MLREE2=IPROGY
  501. SEGACT, MLREE1,MLREE2
  502. DDXMAX=XPAS(IE1)
  503. NNNI=INT(DDXMAX/DDT+1.D-5)
  504. JG=INT(TE/DDXMAX+1.D-5)
  505. C** SEGINI, IMTK2(IE1)
  506. SEGINI,MLREK2
  507. IMTK2(IE1) = MLREK2
  508. TR=TINI
  509. INDICE=2
  510. XTIN=MLREE1.PROG(INDICE-1)
  511. XTOU=MLREE1.PROG(INDICE)
  512. XMIN=MLREE2.PROG(INDICE-1)
  513. RATE=(MLREE2.PROG(INDICE)-XMIN)/(XTOU-XTIN)
  514. DO 816 IE2=1,JG
  515. VMTK2=0.D0
  516. DO 815 IE3=1,NNNI
  517. TR=TR+DDT
  518. IF (TR.GT.(XTOU+1.E-5))THEN
  519. INDICE=INDICE+1
  520. XTOU=MLREE1.PROG(INDICE)
  521. XTIN=MLREE1.PROG(INDICE-1)
  522. XMIN=MLREE2.PROG(INDICE-1)
  523. RATE=(MLREE2.PROG(INDICE)-XMIN)/(XTOU-XTIN)
  524. ENDIF
  525. VMTK2=VMTK2+(XMIN + RATE *(TR-XTIN))**2
  526. 815 CONTINUE
  527. C** IMTK2(IE1).PROG(IE2)=VMTK2/NNNI
  528. MLREK2.PROG(IE2)=VMTK2/NNNI
  529. 816 CONTINUE
  530. IF(IE1.GT.1)DDT=DDT/2
  531. SEGDES MLREE1
  532. SEGDES MLREE2
  533. SEGDES KEVOLL
  534. 817 CONTINUE
  535. C
  536. ELSE
  537. C
  538. DPROC=TE/IPROC
  539. DO 26 IE1=1,NBFREQ
  540. KEVOLL=MEVOL2.IEVOLL(IE1)
  541. SEGACT KEVOLL
  542. MLREE1=IPROGX
  543. MLREE2=IPROGY
  544. SEGACT MLREE1
  545. SEGACT MLREE2
  546. INDICE=2
  547. XTIN=MLREE1.PROG(INDICE-1)
  548. XTOU=MLREE1.PROG(INDICE)
  549. XMIN=MLREE2.PROG(INDICE-1)
  550. RATE=(MLREE2.PROG(INDICE)-XMIN)/(XTOU-XTIN)
  551. DO 25 IE2=1,IPROC
  552. TR=TINI+(IE2-0.5D0)*DPROC
  553. IF (TR.GT.(XTOU+1.E-5))THEN
  554. DO 251 IE3=INDICE,MLREE1.PROG(/1)
  555. INDICE=INDICE+1
  556. XTOU=MLREE1.PROG(INDICE)
  557. IF (TR.LE.(XTOU+1.E-5))GOTO 252
  558. 251 CONTINUE
  559. 252 XTIN=MLREE1.PROG(INDICE-1)
  560. XMIN=MLREE2.PROG(INDICE-1)
  561. RATE=(MLREE2.PROG(INDICE)-XMIN)/(XTOU-XTIN)
  562. ENDIF
  563. XMTK2(IE1,IE2)=(XMIN + RATE *(TR-XTIN))**2
  564. 25 CONTINUE
  565. SEGDES MLREE1
  566. SEGDES MLREE2
  567. SEGDES KEVOLL
  568. 26 CONTINUE
  569. C
  570. ENDIF
  571. C
  572. SEGDES MEVOL2
  573. C
  574. C 5) CALCUL
  575. C
  576. C 5.1) BOUCLE SUR LES PERIODES
  577. C
  578. INEWT=0
  579. C
  580. DPI=8.D0*ATAN(1.D0)
  581. DO 50 IE1=1,NT
  582. FRQ=1/T(IE1)
  583. WN=FRQ*DPI
  584. C WRITE(IOIMP,*)'BOUCLE PERIODE IT ',IE1
  585. C
  586. C 5.2) CALCUL DES MOMENTS STATIQUES
  587. C
  588. DO 30 IE2=1,NBFREQ
  589. CALL MOMENT(FRQ,AMOR,TE,
  590. > IFREQ(2,IE2),F(IFREQ(1,IE2)),S(IFREQ(1,IE2)) ,IGRAND,
  591. > XLSTAT(1,IE2),XLSTAT(2,IE2),XLSTAT(3,IE2) )
  592. 30 CONTINUE
  593. C WRITE(IOIMP,*)'BOUCLE PERIODE CALCUL DES MOMENTS STATIQUES'
  594. C
  595. C 5.3) CALCUL DES MOMENT AU COURS DU TEMPS
  596. C PAR CONTRIBUTION DES PROCESSUS ELEMENTAIRES
  597. C
  598. C 5.3.1) MISE A ZERO
  599. C
  600. DO 35 IE2=1,3
  601. DO 35 IE3=1,NTIME
  602. XLTIME(IE3,IE2)=0.D0
  603. 35 CONTINUE
  604. C
  605. IF(.NOT.LONDEL)THEN
  606. C
  607. C 5.3.2) BOUCLE SUR LES PROCESSUS
  608. C
  609. ROTMA=1-EXP(-2*WN*AMOR*DPROC)
  610. DO 40 IE2=1,IPROC
  611. TPROCD=TINI + (IE2-1)*DPROC
  612. TPROCF=TPROCD+DPROC
  613. C
  614. C 5.3.3) SOMME M(TK)*S*H
  615. DO 36 IE3=1,3
  616. XLTI(IE3)=0.D0
  617. DO 36 IE4=1,NBFREQ
  618. XLTI(IE3)=XLTI(IE3) + XMTK2(IE4,IE2)*XLSTAT(IE3,IE4)
  619. 36 CONTINUE
  620. C
  621. C 5.3.4) FONCTION DE PONDERATION DE H...
  622. C
  623. INDOC=(IE2-1)*IINT + 1
  624. INDOCM=INDOC+IINT
  625. DO 38 IE3=INDOC,NTIME
  626. TTDT=(IE3-1)*DTIME
  627. INDT=IE3
  628. IF (INDT.LE.INDOCM)THEN
  629. ROT=1-EXP(-2*WN*AMOR*(TTDT-TPROCD))
  630. ELSE
  631. ROT=EXP(-2*WN*AMOR*(TTDT-TPROCF))
  632. > -EXP(-2*WN*AMOR*(TTDT-TPROCD))
  633. C
  634. IF((ROT/ROTMA).LT.1.D-3)GOTO 40
  635. C
  636. ENDIF
  637. C 5.3.5) ... ET CONTRIBUTION LAMBDA(T)
  638. C
  639. DO 38 IE4=1,3
  640. XLTIME(INDT,IE4)=XLTIME(INDT,IE4)+
  641. > ROT*XLTI(IE4)
  642. 38 CONTINUE
  643. 40 CONTINUE
  644. C
  645. ELSE
  646. C
  647. C
  648. C 5.3.2.o) BOUCLE SUR LES FREQUENCE
  649. C
  650. DO 823 IE2=1,NBFREQ
  651. C* IPROC=IMTK2(IE2).PROG(/1)
  652. MLREK2 = IMTK2(IE2)
  653. IPROC = MLREK2.PROG(/1)
  654. DPROC=XPAS(IE2)
  655. IINT=INT(DPROC/DTIME+1.D-5)
  656. ROTMA=1-EXP(-2*WN*AMOR*DPROC)
  657. C
  658. C 5.3.2.o) BOUCLE SUR LES PROCESSUS
  659. C
  660. DO 822 IE3=1,IPROC
  661. TPROCD=TINI + (IE3-1)*DPROC
  662. TPROCF=TPROCD+DPROC
  663. C
  664. C 5.3.3.o) PRODUIT M(TK)*S*H
  665. C
  666. SI2I3 = MLREK2.PROG(IE3)
  667. DO 820 IE4=1,3
  668. C** XLTI(IE4)=IMTK2(IE2).PROG(IE3)*XLSTAT(IE4,IE2)
  669. XLTI(IE4) = SI2I3 * XLSTAT(IE4,IE2)
  670. 820 CONTINUE
  671. C
  672. C 5.3.4.o) FONCTION DE PONDERATION DE H...
  673. C
  674. INDOC=(IE3-1)*IINT + 1
  675. INDOCM=INDOC+IINT
  676. DO 821 IE4=INDOC,NTIME
  677. TTDT=(IE4-1)*DTIME
  678. INDT=IE4
  679. IF (INDT.LE.INDOCM)THEN
  680. ROT=1-EXP(-2*WN*AMOR*(TTDT-TPROCD))
  681. ELSE
  682. ROT=EXP(-2*WN*AMOR*(TTDT-TPROCF))
  683. > -EXP(-2*WN*AMOR*(TTDT-TPROCD))
  684. C
  685. IF((ROT/ROTMA).LT.1.D-3)GOTO 822
  686. C
  687. ENDIF
  688. C 5.3.5.o) ... ET CONTRIBUTION LAMBDA(T)
  689. C
  690. DO 821 IE5=1,3
  691. XLTIME(INDT,IE5)=XLTIME(INDT,IE5)+
  692. > ROT*XLTI(IE5)
  693. 821 CONTINUE
  694. 822 CONTINUE
  695. 823 CONTINUE
  696. C
  697. ENDIF
  698. C WRITE(IOIMP,*)'BOUCLE PERIODE CALCUL DES MOMENTS EN TEMPS'
  699. C
  700. C 5.4) CALCUL DU RESPONSE SPECTRA
  701. C
  702. CALL DISTRT(MMTRA, NTIME, DTIME, DPI,
  703. > TE, IDISTR,XRREUR, VALMAX ,IOK ,INEW)
  704. RES(IE1)=VALMAX
  705. IF(IOK.NE.0)THEN
  706. IF(IOK.LT.100)THEN
  707. SEGSUP MTRAV,MMTRA
  708. GOTO 666
  709. ENDIF
  710. ENDIF
  711. C
  712. INEWT=INEWT+INEW
  713. 50 CONTINUE
  714. C WRITE(IOIMP,*)'FIN CALCUL DES RESULTATS'
  715. C
  716. IF(IIMPI.EQ.1)WRITE(IOIMP,*)'NB DE CALCUL DE LA DISTRIBUTION='
  717. > ,INEWT
  718. C
  719. C 6) STOCKAGE DES RESULTAT
  720. C
  721. C 6.1) ABSISSE EN PERIODE OU EN FREQUENCE
  722. C
  723. IF(LPERIO.AND.LUSER)THEN
  724. MLREE1=IPREET
  725. MOTX='PERIODE'
  726. ELSE
  727. JG=NT
  728. SEGINI MLREE1
  729. IF(LPERIO)THEN
  730. DO 60 I=1,NT
  731. MLREE1.PROG(I)=T(I)
  732. 60 CONTINUE
  733. MOTX='PERIODE'
  734. ELSE
  735. DO 61 I=1,NT
  736. MLREE1.PROG(NT-I+1)=1/T(I)
  737. 61 CONTINUE
  738. MOTX='FREQUENCE'
  739. ENDIF
  740. SEGDES MLREE1
  741. ENDIF
  742. C
  743. C 6.2) LEGENDE (PARTIELLE) DES ORDONNEES
  744. C
  745. MOTY(1:10)='RSPE-'//MOTCLE(2+IGRAND)//' '
  746. C
  747. C 6.3) CREATION DE L'OBJET EVOLUTIO RSNS
  748. C
  749. N=1
  750. SEGINI MEVOLL
  751. IPVO=MEVOLL
  752. TI(1:72)=TITREE
  753. IEVTEX=TI
  754. WRITE(TI(64:72),'(A5,I4)')INEWT
  755. ITYEVO='REEL'
  756. C
  757. SEGINI KEVOLL
  758. C
  759. WRITE(TI,100)AMOR
  760. 100 FORMAT(1X,'AMORTISSEMENT DE ',1PD12.5)
  761. KEVTEX=TI
  762. C
  763. IEVOLL(1)=KEVOLL
  764. TYPX='LISTREEL'
  765. TYPY='LISTREEL'
  766. C
  767. IPROGX=MLREE1
  768. NOMEVX=MOTX(1:12)
  769. C
  770. JG=NT
  771. SEGINI MLREE2
  772. IF(LPERIO)THEN
  773. DO 62 I=1,NT
  774. MLREE2.PROG(I)=RES(I)
  775. 62 CONTINUE
  776. ELSE
  777. DO 63 I=1,NT
  778. MLREE2.PROG(NT-I+1)=RES(I)
  779. 63 CONTINUE
  780. ENDIF
  781. SEGDES MLREE2
  782. IPROGY=MLREE2
  783. MOTY(11:12)=' 1'
  784. NOMEVY=MOTY(1:12)
  785. C
  786. NUMEVX=ICOUL
  787. NUMEVY='REEL'
  788. C
  789. SEGDES KEVOLL
  790. SEGDES MEVOLL
  791. C
  792. C 7) DESTRUCTION DE LA ZONE DE TRAVAIL ET RETOUR A GIBIANE
  793. C
  794. SEGSUP MTRAV,MMTRA
  795. IF(LONDEL)THEN
  796. DO 890 IE1=1,NBFREQ
  797. C** SEGSUP, IMTK2(IE1)
  798. MLREK2 = IMTK2(IE1)
  799. SEGSUP,MLREK2
  800. 890 CONTINUE
  801. SEGSUP, MONDE
  802. ENDIF
  803. C
  804. CALL ECROBJ('EVOLUTIO',IPVO)
  805. C
  806. RETURN
  807. C
  808. 663 SEGSUP MONDE
  809. SEGDES MLREEL
  810. SEGDES KEVOLL
  811. 664 SEGDES MLREE1
  812. SEGDES KEVOL1
  813. SEGDES MEVOL1
  814. 665 SEGDES MEVOL2
  815. SEGDES MLREE3
  816. 666 CONTINUE
  817. RETURN
  818. END
  819.  
  820.  
  821.  
  822.  
  823.  
  824.  
  825.  
  826.  
  827.  
  828.  
  829.  
  830.  

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