C SPO SOURCE OF166741 25/02/20 21:17:39 12165 SUBROUTINE SPO IMPLICIT INTEGER(I-N) IMPLICIT REAL*8(A-H,O-Z) CHARACTER*72 TI CHARACTER*(4) CMOT c c ======================================================== c = c spectres d' oscillateur = c = c syntaxe : evol = spo evol1 amor lamor (freq lfreq) = c = c (temp ltemp) (coul cool) sortie = c = c creation : 03/06/87 = c programmeur : malaval = c = c modification : 17/12/90 = c programmeur : a.pinto and p.pegon = c = c ======================================================== c -INC PPARAM -INC CCOPTIO -INC SMEVOLL -INC SMLREEL -INC CCGEOME -INC CCREEL cap 7-->8, 3-->4 et vrai acc CHARACTER*4 MODOM(8) CHARACTER*12 ITITY(4) DATA MODOM/'AMOR','FREQ','TEMP','COUL','DEPL','VITE','ACCE', *'ACCA'/ DATA ITITY /'DEPLMAXIMAUX','PSEUDO VITES','PSEUDO ACCEL', *'ABSOLUTE ACC'/ LMOT=8 cap ITEMP=0 IAMOR=0 IFREQ=0 ICOUL1=IDCOUL N0=0 c c lecture des mots c DO 10 I=1,5 CALL LIRMOT(MODOM,LMOT,IPLAC,0) IF (IPLAC.EQ.0) GOTO 10 cap +12 8 GOTO (1,2,3,4,5,6,7,12),IPLAC cap 1 CONTINUE c c amortissement c CALL LIROBJ ('LISTREEL',IPAMOR,1,IRET) IAMOR=1 GOTO 10 c 2 CONTINUE c c frequence c CALL LIROBJ ('LISTREEL',IPFREQ,1,IRET) IFREQ=1 GOTO 10 c 3 CONTINUE c c temps c CALL LIROBJ ('LISTREEL',IPT,1,IRET) ITEMP=1 GOTO 10 c 4 CONTINUE c c couleurs c CALL LIRMOT (NCOUL(0),NBCOUL,ICOUL1,0) IF (ICOUL1.EQ.0) ICOUL1=IDCOUL+1 ICOUL1=ICOUL1-1 GOTO10 c 5 CONTINUE c c spectre en deplacement relatif c N0=1 GOTO 10 c 6 CONTINUE c c spectre en pseudo vitesse c N0=2 GOTO 10 c 7 CONTINUE c c spectre en pseudo acceleration c N0=3 GOTO 10 cap 12 CONTINUE c c spectre en acceleration absolute c N0=4 GOTO 10 cap c 10 CONTINUE c IF (N0.EQ.0 ) THEN CALL ERREUR (6) RETURN ENDIF c IF (IAMOR.EQ.0 ) THEN CALL ERREUR (361) RETURN ENDIF MLREEL=IPAMOR SEGACT MLREEL DO 11 NBAM=1,PROG(/1) IF (PROG(NBAM).LT.0.OR.PROG(NBAM).GE.1) THEN MOTERR(1:8)='AMORTISS' REAERR(1)=PROG(NBAM) REAERR(2)=0. REAERR(3)=1. SEGDES MLREEL CALL ERREUR(42) RETURN ENDIF 11 CONTINUE SEGDES MLREEL c c temps et acceleration de l'objet evolution c CALL LIROBJ ('EVOLUTIO',IPOEVO,1,IRET) MEVOLL=IPOEVO SEGACT MEVOLL KEVOLL=IEVOLL(1) SEGACT KEVOLL IPTG=IPROGX IPGG=IPROGY SEGDES MEVOLL SEGDES KEVOLL IF (ITEMP.EQ.0) THEN MLREE1=IPTG SEGACT MLREE1 MLREE2=IPGG SEGACT MLREE2 LONT=MLREE1.PROG(/1) TPS=MLREE1.PROG(LONT) DT=TPS/(LONT-1) NA=TPS/(2*DT) JG = LONT+NA SEGINI MLREEL IPT=MLREEL SEGINI MLREE3 IPG=MLREE3 TPT=3*TPS/2 DO 51 LL=1,LONT MLREEL.PROG(LL)=MLREE1.PROG(LL) MLREE3.PROG(LL)=MLREE2.PROG(LL) 51 CONTINUE DO 52 LL=LONT,(LONT+NA-1) MLREEL.PROG(LL+1)=MLREEL.PROG(LL)+DT MLREE3.PROG(LL+1)=0.D0 52 CONTINUE TPSMAX = MLREE3.PROG(LONT+NA-2) SEGDES MLREE1 SEGDES MLREE2 SEGDES MLREEL SEGDES MLREE3 GOTO 70 ELSE MLREE3=IPT SEGACT MLREE3 LONT = MLREE3.PROG(/1) TPSMAX = MLREE3.PROG(LONT-2) SEGDES MLREE3 c c appel a la subroutine d'interpolation c CALL INTE33(IPTG,IPGG,IPT,IPG) ENDIF c c c appel a la subroutine contenant l'algorithme c 70 MLREEL=IPAMOR SEGACT MLREEL N1=MLREEL.PROG(/1) N=N1 SEGINI MEVOLL IPOEVO=MEVOLL c c creation eventuelle d'une liste de frequences c IF (IFREQ.EQ.0) THEN MLREE3=IPTG SEGACT MLREE3 LONT=MLREE3.PROG(/1) TPS=MLREE3.PROG(LONT) SEGDES MLREE3 c c pas moyen du signal c DT=TPS/(LONT-1) c c frequence la plus basse c F1=1/TPS c c frequence la plus haute c F3=1/(2*DT) c ELSE MLREE3=IPTG SEGACT MLREE3 LONT=MLREE3.PROG(/1) TPS=MLREE3.PROG(LONT) SEGDES MLREE3 ENDIF c c boucle sur les differents amortissements c DO 100 I=1,N1 c mlreel=ipamor XSI=MLREEL.PROG(I) JG=0 SEGINI MLREE2 IPSPO=MLREE2 IF (IFREQ.NE.0) GOTO 42 c c frequence de separation c IF (XSI.NE.0.) THEN F2=1/(XSI*TPS) ELSE F2=F3 ENDIF c c nombre d'intervalles successifs de largeur f1 entre f1 et f2 c N3=(F2-F1)/F1 c c c creation de l'objet listreel c JG=N3 SEGINI MLREE1 IPFREQ=MLREE1 MLREE1.PROG(1)=F1 DO 102 K=1,N3-1 MLREE1.PROG(K+1)=MLREE1.PROG(K)+F1 102 CONTINUE Z=MLREE1.PROG(N3) IF (Z.NE.F2) THEN JG=N3+1 SEGADJ MLREE1 MLREE1.PROG(JG)=F2 N5=N3+1 ELSE N5=N3 ENDIF c c nombre des intervalles de largeur variable , pris en compte c entre f2 et f3 c IF (XSI.NE.0.) THEN N4=N5+(LOG(F3/F2)/LOG(1+XSI)) JG=N4 SEGADJ MLREE1 DO 103 K=N5,N4-1 MLREE1.PROG(K+1)=(1+XSI)*MLREE1.PROG(K) 103 CONTINUE SEGDES MLREE1 ENDIF c 42 MLREE1=IPFREQ SEGACT MLREE1 N2=MLREE1.PROG(/1) M=0 c c c boucle sur les frequences c JG0=MLREE2.PROG(/1) JG=JG0+N2 SEGADJ MLREE2 DO 101 J=1,N2 c mlree1=ipfreq DFREQ=MLREE1.PROG(J) W=2*XPI*DFREQ W2=W*W cap CALL INOSC1 (IPT,IPG,DFREQ,XSI,RMAX,TMAX,AMAX) cap IF (TMAX.GT.TPS) THEN c le maximum est atteint près la fin du signal IF ( (TMAX-TPSMAX) .GE. 0.D0)THEN c le maximum est atteint a la fin de l'intervale d'étude : mauvais ! REAERR(1)=XSI REAERR(2)=DFREQ CALL ERREUR(-311) ENDIF M=M+1 ENDIF c mlree2=ipspo IF (N0.EQ.1) MLREE2.PROG(JG0+J)=RMAX IF (N0.EQ.2) MLREE2.PROG(JG0+J)=W*RMAX IF (N0.EQ.3) MLREE2.PROG(JG0+J)=W2*RMAX cap IF (N0.EQ.4) MLREE2.PROG(JG0+J)=AMAX cap 101 CONTINUE c c message pour signaler que le maximum est atteint apres la fin du signal c IF ( M .NE. 0) THEN REAERR(1)=XSI INTERR(1)=M CALL ERREUR(-312) ENDIF c SEGINI KEVOLL IEVOLL(I)=KEVOLL TYPX='LISTREEL' TYPY='LISTREEL' IPROGX=IPFREQ IPROGY=IPSPO NOMEVX='FREQUENCE' NOMEVY=ITITY(N0) NUMEVX=ICOUL1 NUMEVY='REEL' TI(1:72)=TITREE IEVTEX=TI ITYEVO='REEL' c KEVTEX=TI KEVTEX=NOMEVY SEGDES KEVOLL SEGDES MLREE2 100 CONTINUE SEGDES MEVOLL SEGDES MLREE1 SEGDES MLREEL c c CALL ECROBJ ('EVOLUTIO',IPOEVO) RETURN END