Télécharger la plaquette Cast3M


fr en

Télécharger prns.eso

Retour à la liste

Numérotation des lignes : 

prns

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

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