1 : C SPON SOURCE PV 12/04/12 21:15:09 7351
2 : SUBROUTINE SPON
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 NON LINEAIRES D' OSCILLATEUR =
11 : C =
12 : C SYNTAXE : EVOL = SPON 'SIGN' EVOL1 'SPEL' EVOL2 MOTENTR=
13 : C =
14 : C 'AMOR' LAMOR 'PROP' LPROP =
15 : C =
16 : C ('COUL' COOL) SORTIE =
17 : C =
18 : C CREATION : 1990/06/15 =
19 : C PROGRAMMEUR : A.PINTO $ P.PEGON (CEC-JRC ISPRA) =
20 : C (BASE : SUBROUTINE SPO) =
21 : C 7/90 =
22 : C ========================================================
23 : C
24 : -INC CCOPTIO
25 : -INC SMEVOLL
26 : -INC SMLREEL
27 : -INC CCGEOME
28 : *-
29 : -INC CCREEL
30 : PARAMETER (LMOT=13)
31 :
32 : CHARACTER*4 MODOM(13)
33 : CHARACTER*12 ITITY(4)
34 : DATA MODOM/'DEMA','SIGN','SPEL','AMOR',
35 : 1 'TAKE','ISOT','CINE','ELAS',
36 : & 'COUL','DEPL','VITE','ACCE','EPSE'/
37 : DATA ITITY /'DEPL MAXIMAU','PSEUDO VITES','PSEUDO ACCEL',
38 : & 'DEFNL CUMULE'/
39 : IPAMOR=0
40 : IPPROP=0
41 : ICOUL1=IDCOUL
42 : IPOEVO=0
43 : IPSPEV=0
44 : idema = 0
45 : N0=-1
46 : C
47 : C LECTURE DES OBJETS
48 : C ==================
49 : C
50 :
51 : DO 10 I=1,13
51 : CALL LIRMOT(MODOM,LMOT,IPLAC,0)
52 : IF (IPLAC.EQ.0) GOTO 12
53 : C
54 : 8 GOTO (20,21,22,23,24,24,24,24,
55 : & 25,26,26,26,26),IPLAC
56 : C
57 :
58 : 20 continue
59 : idema = 1
60 : goto 10
61 : 21 CONTINUE
62 : C
63 : C TEMPS ET ACCELERATION DU SIGNAL (OBJET EVOLUTION)
64 : C
64 : CALL LIROBJ ('EVOLUTIO',IPOEVO,1,IRET)
65 : IF (IRET.EQ.0) RETURN
66 : GOTO 10
67 : C
68 : 22 CONTINUE
69 : C
70 : C SPECTRES LINEAIRES (OBJET EVOLUTION)
71 : C
71 : CALL LIROBJ ('EVOLUTIO',IPSPEV,1,IRET)
72 : IF (IRET.EQ.0) RETURN
73 : C
74 : C TYPE DES SPECTRES LINEAIRES (OBJET MOT)
75 : C ( 'DEPL', 'VITE', 'ACCE' )
76 : C
76 : CALL LIRMOT(MODOM(10),3,ITYP,1)
77 : IF (ITYP.EQ.0) RETURN
78 : NN0=ITYP-1
79 : GOTO 10
80 : C
81 : 23 CONTINUE
82 : C
83 : C AMORTISSEMENT
84 : C
84 : CALL LIROBJ ('LISTREEL',IPAMOR,1,IRET)
85 : IF (IRET.EQ.0) RETURN
86 : GOTO 10
87 : C
88 : 24 CONTINUE
89 : C
90 : C PROPRIETES
91 : C
92 : imod = iplac - 4
92 : CALL LIROBJ ('LISTREEL',IPPROP,1,IRET)
93 : IF (IRET.EQ.0) RETURN
94 : GOTO 10
95 : C
96 : 25 CONTINUE
97 : C
98 : C COULEURS
99 : C
99 : CALL LIRMOT (NCOUL,NBCOUL,ICOUL1,1)
100 : IF (ICOUL1.EQ.0) RETURN
101 : icoul1=icoul1-1
102 : GOTO 10
103 : C
104 : 26 CONTINUE
105 : C
106 : C TYPE DE LA REPONSE (SORTIE)
107 : C
108 : N0=IPLAC-10
109 : GOTO 10
110 : C
111 : 10 CONTINUE
112 : 12 CONTINUE
113 : C
114 : C ON VERIFIE L' EXISTENCE DES DONNES
115 : C ==================================
116 : C
117 : IF (IPOEVO.EQ.0)THEN
117 : CALL ERREUR(588)
118 : RETURN
119 : ENDIF
120 : C
121 : IF (IPSPEV.EQ.0)THEN
121 : CALL ERREUR(589)
122 : RETURN
123 : ENDIF
124 : C
125 : IF (N0.EQ.-1)THEN
125 : CALL ERREUR(590)
126 : RETURN
127 : ENDIF
128 : C
129 : IF (IPAMOR.EQ.0 ) THEN
129 : CALL ERREUR(361)
130 : RETURN
131 : ENDIF
132 : C
133 : IF (IPPROP.EQ.0 ) THEN
133 : CALL ERREUR(591)
134 : RETURN
135 : ENDIF
136 : C
137 : C ON VERIFIE LA CONSISTENCE DES DONNES
138 : C ====================================
139 : C
140 : C AMORTISSEMENT
141 : C
142 : MLREEL=IPAMOR
143 : SEGACT MLREEL
144 : NNBAM=PROG(/1)
145 : DO 11 NBAM=1,NNBAM
146 : IF (PROG(NBAM).LT.0.OR.PROG(NBAM).GE.1) THEN
147 : MOTERR(1:8)='AMORTISS'
148 : REAERR(1)=PROG(NBAM)
149 : REAERR(2)=0.
150 : REAERR(3)=1.
151 : SEGDES MLREEL
151 : CALL ERREUR(42)
152 : RETURN
153 : ENDIF
154 : 11 CONTINUE
155 : SEGDES MLREEL
156 : C
157 : C PROPRIETES
158 : C
159 : MLREEL=IPPROP
160 : SEGACT MLREEL
161 : NNPRO=PROG(/1)
162 : IF (NNPRO.NE.5 .and.imod.eq.1) THEN
163 : INTERR(1)=5
163 : CALL ERREUR(592)
164 : SEGDES MLREEL
165 : RETURN
166 : else if (NNPRO.NE.2 .and.imod.ne.1) then
167 : INTERR(1)=2
167 : CALL ERREUR(592)
168 : SEGDES MLREEL
169 : RETURN
170 : else if (NNPRO.eq.2 .and.imod.ne.1) then
171 : * modele bilineaire elastoplastique ou elastique
172 : * on met n'importe quoi dans les 3 parametres qui servent à rien
173 : alfa = 0.d0
174 : beta = 0.d0
175 : gama = 0.d0
176 : ENDIF
177 : IF (PROG(1).LT.1) THEN
177 : CALL ERREUR(593)
178 : SEGDES MLREEL
179 : RETURN
180 : ENDIF
181 : IF (abs(PROG(2)).GT.1. and. imod.ne.4) THEN
181 : CALL ERREUR(594)
182 : SEGDES MLREEL
183 : RETURN
184 : ENDIF
185 : IF (PROG(2).LT.0D0 .AND. IMOD.EQ.1) THEN
186 : MOTERR='TETA'
186 : CALL ERREUR(595)
187 : SEGDES MLREEL
188 : RETURN
189 : ENDIF
190 : if (imod.eq.1) then
191 : IF (PROG(3).LT.0) THEN
192 : MOTERR='ALFA'
192 : CALL ERREUR(595)
193 : SEGDES MLREEL
194 : RETURN
195 : ENDIF
196 : IF (PROG(4).LT.0) THEN
197 : MOTERR='BETA'
197 : CALL ERREUR(595)
198 : SEGDES MLREEL
199 : RETURN
200 : ENDIF
201 : IF (PROG(5).LT.0) THEN
202 : MOTERR='GAMA'
202 : CALL ERREUR(595)
203 : SEGDES MLREEL
204 : RETURN
205 : ENDIF
206 : endif
207 : C
208 : C PROPRIETES: TOUT EN ORDE
209 : C
210 : DUCT=PROG(1)
211 : TETA=PROG(2)
212 : if (imod.eq.1) then
213 : ALFA=PROG(3)
214 : BETA=PROG(4)
215 : GAMA=PROG(5)
216 : endif
217 : SEGDES MLREEL
218 : C
219 : C LE SIGNAL
220 : C
221 : MEVOLL=IPOEVO
222 : SEGACT MEVOLL
223 : KEVOLL=IEVOLL(1)
224 : SEGACT KEVOLL
225 : MLREEL=IPROGX
226 : SEGACT MLREEL
227 : ILONT=PROG(/1)
228 : TE=PROG(ILONT)-PROG(1)
229 : DTEMPO=TE/(ILONT-1.)
230 : DT=PROG(2)-PROG(1)
231 : DTT=DTEMPO-DT
232 : IF (ABS(DTT).GT.1.D-6) THEN
232 : CALL ERREUR(568)
233 : SEGDES MLREEL
234 : SEGDES KEVOLL
235 : SEGDES MEVOLL
236 : RETURN
237 : ENDIF
238 : IPT=IPROGX
239 : IPG=IPROGY
240 : SEGDES MLREEL
241 : SEGDES KEVOLL
242 : SEGDES MEVOLL
243 : C
244 : C ON RECOUPERE LE NB. DE SPECTRES
245 : C
246 : MEVOLL=IPSPEV
247 : SEGACT MEVOLL
248 : NBCOUR=IEVOLL(/1)
249 : SEGDES MEVOLL
250 : C
251 : C ON COMPARE LE NB. D'AMORTISSEMENTS AVEC LE NB. DE SPECTRES
252 : C
253 : IF (NBCOUR.NE.NNBAM) THEN
253 : CALL ERREUR(596)
254 : RETURN
255 : ENDIF
256 : C
257 : C ON COMMENCE FINALEMENT !!!
258 : C ==========================
259 : C
260 : MLREEL=IPAMOR
261 : SEGACT MLREEL
262 : N1=PROG(/1)
263 : N=N1
264 : SEGINI MEVOLL
265 : IPEVOF=MEVOLL
266 : C
267 : MLREE3=IPT
268 : SEGACT MLREE3
269 : LONT=MLREE3.PROG(/1)
270 : TPS=MLREE3.PROG(LONT)
271 : SEGDES MLREE3
272 : C
273 : MEVOL1=IPSPEV
274 : SEGACT MEVOL1
275 : C
276 : C BOUCLE SUR LES DIFFERENTS AMORTISSEMENTS
277 : C
278 : DO 100 I=1,N1
279 : C MLREEL=IPAMOR
280 : XSI=PROG(I)
281 : C
282 : KEVOL1=MEVOL1.IEVOLL(I)
283 : SEGACT KEVOL1
284 : MLREE1=KEVOL1.IPROGX
285 : MLREE3=KEVOL1.IPROGY
286 : SEGDES KEVOL1
287 : SEGACT MLREE1
288 : SEGACT MLREE3
289 : C
290 : N2=MLREE1.PROG(/1)
291 : M=0
292 : IAUX=0
293 :
294 : C
295 : C
296 : C BOUCLE SUR LES FREQUENCES
297 : C
298 : JG=N2
299 : SEGINI MLREE2
300 : IPSPO=MLREE2
301 : C
302 : DO 101 J=1,N2
303 : DFREQ=MLREE1.PROG(J)
304 : AUX=1/(10.*DFREQ)
305 : IF (DT.GT.AUX) THEN
306 : IF (IAUX.EQ.0) THEN
307 : DPERIO=1/DFREQ
308 : IAUX=1
309 : ENDIF
310 : ENDIF
311 : W=2*XPI*DFREQ
312 : W2=W*W
313 : C
314 : SPECTL=MLREE3.PROG(J)
315 :
316 : C
317 : IF (NN0.EQ.0) DISMAX=SPECTL
318 : IF (NN0.EQ.1) DISMAX=SPECTL/W
319 : IF (NN0.EQ.2) DISMAX=SPECTL/W2
320 : C
321 : C APPEL A LA SUBROUTINE CONTENANT L'ALGORITHME
322 : C
322 : CALL INOSC2(IPT,IPG,DFREQ,XSI,RMAX,TMAX,
323 : 1 DISMAX,DUCT,ALFA,BETA,GAMA,TETA,imod,idema,xepse)
324 :
325 : C
326 : IF (TMAX.GT.TPS) M=M+1
327 : C MLREE2=IPSPO
328 : IF (N0.EQ.0) MLREE2.PROG(J)=RMAX
329 : IF (N0.EQ.1) MLREE2.PROG(J)=W*RMAX
330 : IF (N0.EQ.2) MLREE2.PROG(J)=W2*RMAX
331 : IF (N0.EQ.3) MLREE2.PROG(J)=XEPSE
332 : 101 CONTINUE
333 : C
334 : SEGINI KEVOLL
335 : IEVOLL(I)=KEVOLL
336 : TYPX='LISTREEL'
337 : TYPY='LISTREEL'
338 : IPROGX=MLREE1
339 : IPROGY=IPSPO
340 : NOMEVX='FREQUENCE'
341 : NOMEVY=ITITY(N0+1)
342 : NUMEVX=ICOUL1
343 : NUMEVY='REEL'
344 : TI(1:72)=TITREE
345 : IEVTEX=TI
346 : ITYEVO='REEL'
347 : KEVTEX=TI
348 : SEGDES KEVOLL
349 : SEGDES MLREE2
350 : SEGDES MLREE1
351 : SEGDES MLREE3
352 : 100 CONTINUE
353 : C
354 : 38 FORMAT(1X,'SPON : POUR L AMORTISSEMENT',E12.5/
355 : >1X,' IL Y A',I5,3X,'DEPLACEMENTS MAXIMAUX'/
356 : >1X,' APRES LA FIN DU SIGNAL')
357 : 300 FORMAT(1X,'SPON : POUR L AMORTISSEMENT',E12.5/
358 : >1X,' POUR LES FREQUENCES ( F ) >',E12.5/
359 : >1X,' ( PERIODES ( T ) ) <',E12.5/
360 : >1X,' LA CONDITION ( DT < 1/(10*F) ) (ACCURACY)'/
361 : >1X,' N EST PAS VERIFIE')
362 : C
363 : SEGDES MEVOLL
364 : SEGDES MLREEL
365 : SEGDES MEVOL1
366 : C
367 : C
367 : CALL ECROBJ ('EVOLUTIO',IPEVOF)
368 : RETURN
369 : END
370 :
371 :
372 :
373 :
374 :
375 :
376 :
377 :
378 :
379 :
380 :
381 :
382 :
383 :
© Cast3M 2003 - All rights reserved.
Disclaimer