1 : C SPO SOURCE CHAT 07/10/29 21:28:40 5940 2 : SUBROUTINE SPO 3 : IMPLICIT INTEGER(I-N) 4 : IMPLICIT REAL*8(A-H,O-Z) 5 : CHARACTER*72 TI 6 : CHARACTER*(4) CMOT 7 : c 8 : c ======================================================== 9 : c = 10 : c spectres d' oscillateur = 11 : c = 12 : c syntaxe : evol = spo evol1 amor lamor (freq lfreq) = 13 : c = 14 : c (temp ltemp) (coul cool) sortie = 15 : c = 16 : c creation : 03/06/87 = 17 : c programmeur : malaval = 18 : c = 19 : c modification : 17/12/90 = 20 : c programmeur : a.pinto and p.pegon = 21 : c = 22 : c ======================================================== 23 : c 24 : -INC CCOPTIO 25 : -INC SMEVOLL 26 : -INC SMLREEL 27 : -INC CCGEOME 28 : -INC CCREEL 29 : cap 7-->8, 3-->4 et vrai acc 30 : CHARACTER*4 MODOM(8) 31 : CHARACTER*12 ITITY(4) 32 : DATA MODOM/'AMOR','FREQ','TEMP','COUL','DEPL','VITE','ACCE', 33 : *'ACCA'/ 34 : DATA ITITY /'DEPLMAXIMAUX','PSEUDO VITES','PSEUDO ACCEL', 35 : *'ABSOLUTE ACC'/ 36 : LMOT=8 37 : cap 38 : ITEMP=0 39 : IAMOR=0 40 : IFREQ=0 41 : ICOUL1=IDCOUL 42 : N0=0 43 : c 44 : c lecture des mots 45 : c 46 : DO 10 I=1,5 46 : CALL LIRMOT(MODOM,LMOT,IPLAC,0) 47 : IF (IPLAC.EQ.0) GOTO 10 48 : cap +12 49 : 8 GOTO (1,2,3,4,5,6,7,12),IPLAC 50 : cap 51 : 1 CONTINUE 52 : c 53 : c amortissement 54 : c 54 : CALL LIROBJ ('LISTREEL',IPAMOR,1,IRET) 55 : IAMOR=1 56 : GOTO 10 57 : c 58 : 2 CONTINUE 59 : c 60 : c frequence 61 : c 61 : CALL LIROBJ ('LISTREEL',IPFREQ,1,IRET) 62 : IFREQ=1 63 : GOTO 10 64 : c 65 : 3 CONTINUE 66 : c 67 : c temps 68 : c 68 : CALL LIROBJ ('LISTREEL',IPT,1,IRET) 69 : ITEMP=1 70 : GOTO 10 71 : c 72 : 4 CONTINUE 73 : c 74 : c couleurs 75 : c 75 : CALL LIRMOT (NCOUL(0),NBCOUL,ICOUL1,0) 76 : IF (ICOUL1.EQ.0) ICOUL1=IDCOUL+1 77 : ICOUL1=ICOUL1-1 78 : GOTO10 79 : c 80 : 5 CONTINUE 81 : c 82 : c spectre en deplacement relatif 83 : c 84 : N0=1 85 : GOTO 10 86 : c 87 : 6 CONTINUE 88 : c 89 : c spectre en pseudo vitesse 90 : c 91 : N0=2 92 : GOTO 10 93 : c 94 : 7 CONTINUE 95 : c 96 : c spectre en pseudo acceleration 97 : c 98 : N0=3 99 : GOTO 10 100 : cap 101 : 12 CONTINUE 102 : c 103 : c spectre en acceleration absolute 104 : c 105 : N0=4 106 : GOTO 10 107 : cap 108 : c 109 : 10 CONTINUE 110 : c 111 : IF (N0.EQ.0 ) THEN 111 : CALL ERREUR (6) 112 : RETURN 113 : ENDIF 114 : c 115 : IF (IAMOR.EQ.0 ) THEN 115 : CALL ERREUR (361) 116 : RETURN 117 : ENDIF 118 : MLREEL=IPAMOR 119 : SEGACT MLREEL 120 : DO 11 NBAM=1,PROG(/1) 121 : IF (PROG(NBAM).LT.0.OR.PROG(NBAM).GE.1) THEN 122 : MOTERR(1:8)='AMORTISS' 123 : REAERR(1)=PROG(NBAM) 124 : REAERR(2)=0. 125 : REAERR(3)=1. 126 : SEGDES MLREEL 126 : CALL ERREUR(42) 127 : RETURN 128 : ENDIF 129 : 11 CONTINUE 130 : SEGDES MLREEL 131 : c 132 : c temps et acceleration de l'objet evolution 133 : c 133 : CALL LIROBJ ('EVOLUTIO',IPOEVO,1,IRET) 134 : MEVOLL=IPOEVO 135 : SEGACT MEVOLL 136 : KEVOLL=IEVOLL(1) 137 : SEGACT KEVOLL 138 : IPTG=IPROGX 139 : IPGG=IPROGY 140 : SEGDES MEVOLL 141 : SEGDES KEVOLL 142 : IF (ITEMP.EQ.0) THEN 143 : MLREE1=IPTG 144 : SEGACT MLREE1 145 : MLREE2=IPGG 146 : SEGACT MLREE2 147 : LONT=MLREE1.PROG(/1) 148 : TPS=MLREE1.PROG(LONT) 149 : DT=TPS/(LONT-1) 150 : NA=TPS/(2*DT) 151 : JG = LONT+NA 152 : SEGINI MLREEL 153 : IPT=MLREEL 154 : SEGINI MLREE3 155 : IPG=MLREE3 156 : TPT=3*TPS/2 157 : DO 51 LL=1,LONT 158 : MLREEL.PROG(LL)=MLREE1.PROG(LL) 159 : MLREE3.PROG(LL)=MLREE2.PROG(LL) 160 : 51 CONTINUE 161 : DO 52 LL=LONT,(LONT+NA-1) 162 : MLREEL.PROG(LL+1)=MLREEL.PROG(LL)+DT 163 : MLREE3.PROG(LL+1)=0.D0 164 : 52 CONTINUE 165 : TPSMAX = MLREE3.PROG(LONT+NA-2) 166 : SEGDES MLREE1 167 : SEGDES MLREE2 168 : SEGDES MLREEL 169 : SEGDES MLREE3 170 : GOTO 70 171 : ELSE 172 : MLREE3=IPT 173 : SEGACT MLREE3 174 : LONT = MLREE3.PROG(/1) 175 : TPSMAX = MLREE3.PROG(LONT-2) 176 : SEGDES MLREE3 177 : 178 : c 179 : c appel a la subroutine d'interpolation 180 : c 180 : CALL INTE33(IPTG,IPGG,IPT,IPG) 181 : 182 : ENDIF 183 : c 184 : c 185 : c appel a la subroutine contenant l'algorithme 186 : c 187 : 70 MLREEL=IPAMOR 188 : SEGACT MLREEL 189 : N1=MLREEL.PROG(/1) 190 : N=N1 191 : SEGINI MEVOLL 192 : IPOEVO=MEVOLL 193 : c 194 : c creation eventuelle d'une liste de frequences 195 : c 196 : IF (IFREQ.EQ.0) THEN 197 : MLREE3=IPTG 198 : SEGACT MLREE3 199 : LONT=MLREE3.PROG(/1) 200 : TPS=MLREE3.PROG(LONT) 201 : SEGDES MLREE3 202 : c 203 : c pas moyen du signal 204 : c 205 : DT=TPS/(LONT-1) 206 : c 207 : c frequence la plus basse 208 : c 209 : F1=1/TPS 210 : c 211 : c frequence la plus haute 212 : c 213 : F3=1/(2*DT) 214 : c 215 : ELSE 216 : MLREE3=IPTG 217 : SEGACT MLREE3 218 : LONT=MLREE3.PROG(/1) 219 : TPS=MLREE3.PROG(LONT) 220 : SEGDES MLREE3 221 : ENDIF 222 : c 223 : c boucle sur les differents amortissements 224 : c 225 : DO 100 I=1,N1 226 : c mlreel=ipamor 227 : XSI=MLREEL.PROG(I) 228 : JG=0 229 : SEGINI MLREE2 230 : IPSPO=MLREE2 231 : IF (IFREQ.NE.0) GOTO 42 232 : c 233 : c frequence de separation 234 : c 235 : IF (XSI.NE.0.) THEN 236 : F2=1/(XSI*TPS) 237 : ELSE 238 : F2=F3 239 : ENDIF 240 : c 241 : c nombre d'intervalles successifs de largeur f1 entre f1 et f2 242 : c 243 : N3=(F2-F1)/F1 244 : c 245 : c 246 : c creation de l'objet listreel 247 : c 248 : JG=N3 249 : SEGINI MLREE1 250 : IPFREQ=MLREE1 251 : MLREE1.PROG(1)=F1 252 : DO 102 K=1,N3-1 253 : MLREE1.PROG(K+1)=MLREE1.PROG(K)+F1 254 : 102 CONTINUE 255 : Z=MLREE1.PROG(N3) 256 : IF (Z.NE.F2) THEN 257 : JG=N3+1 258 : SEGADJ MLREE1 259 : MLREE1.PROG(JG)=F2 260 : N5=N3+1 261 : ELSE 262 : N5=N3 263 : ENDIF 264 : c 265 : c nombre des intervalles de largeur variable , pris en compte 266 : c entre f2 et f3 267 : c 268 : IF (XSI.NE.0.) THEN 269 : N4=N5+(LOG(F3/F2)/LOG(1+XSI)) 270 : JG=N4 271 : SEGADJ MLREE1 272 : DO 103 K=N5,N4-1 273 : MLREE1.PROG(K+1)=(1+XSI)*MLREE1.PROG(K) 274 : 103 CONTINUE 275 : SEGDES MLREE1 276 : ENDIF 277 : c 278 : 42 MLREE1=IPFREQ 279 : SEGACT MLREE1 280 : N2=MLREE1.PROG(/1) 281 : M=0 282 : c 283 : c 284 : c boucle sur les frequences 285 : c 286 : 287 : JG0=MLREE2.PROG(/1) 288 : JG=JG0+N2 289 : SEGADJ MLREE2 290 : DO 101 J=1,N2 291 : c mlree1=ipfreq 292 : DFREQ=MLREE1.PROG(J) 293 : W=2*XPI*DFREQ 294 : W2=W*W 295 : cap 295 : CALL INOSC1 (IPT,IPG,DFREQ,XSI,RMAX,TMAX,AMAX) 296 : cap 297 : IF (TMAX.GT.TPS) THEN 298 : c le maximum est atteint près la fin du signal 299 : IF ( (TMAX-TPSMAX) .GE. 0.D0)THEN 300 : c le maximum est atteint a la fin de l'intervale d'étude : mauvais ! 301 : REAERR(1)=XSI 302 : REAERR(2)=DFREQ 302 : CALL ERREUR(-311) 303 : ENDIF 304 : M=M+1 305 : ENDIF 306 : c mlree2=ipspo 307 : IF (N0.EQ.1) MLREE2.PROG(JG0+J)=RMAX 308 : IF (N0.EQ.2) MLREE2.PROG(JG0+J)=W*RMAX 309 : IF (N0.EQ.3) MLREE2.PROG(JG0+J)=W2*RMAX 310 : cap 311 : IF (N0.EQ.4) MLREE2.PROG(JG0+J)=AMAX 312 : cap 313 : 101 CONTINUE 314 : c 315 : c message pour signaler que le maximum est atteint apres la fin du signal 316 : c 317 : IF ( M .NE. 0) THEN 318 : REAERR(1)=XSI 319 : INTERR(1)=M 319 : CALL ERREUR(-312) 320 : ENDIF 321 : c 322 : SEGINI KEVOLL 323 : IEVOLL(I)=KEVOLL 324 : TYPX='LISTREEL' 325 : TYPY='LISTREEL' 326 : IPROGX=IPFREQ 327 : IPROGY=IPSPO 328 : NOMEVX='FREQUENCE' 329 : NOMEVY=ITITY(N0) 330 : NUMEVX=ICOUL1 331 : NUMEVY='REEL' 332 : TI(1:72)=TITREE 333 : IEVTEX=TI 334 : ITYEVO='REEL' 335 : KEVTEX=TI 336 : SEGDES KEVOLL 337 : SEGDES MLREE2 338 : 100 CONTINUE 339 : SEGDES MEVOLL 340 : SEGDES MLREE1 341 : SEGDES MLREEL 342 : c 343 : c 343 : CALL ECROBJ ('EVOLUTIO',IPOEVO) 344 : RETURN 345 : END 346 : 347 : 348 : 349 : 350 : 351 : 352 : 353 : 354 : 355 : 356 : 357 : 358 :
© Cast3M 2003 - All rights reserved.
Disclaimer