1 : C PSMO SOURCE CHAT 09/10/09 21:22:03 6519
2 : SUBROUTINE PSMO
3 : IMPLICIT INTEGER(I-N)
4 : IMPLICIT REAL*8(A-H,O-Z)
5 : ************************************************************************
6 : *
7 : * P S M O
8 : * -------
9 : *
10 : * Sous-programme associ{ @ l'op{rateur "PSMO"
11 : *
12 : * FONCTION:
13 : * ---------
14 : *
15 : * L'op{rateur "PSMO" calcule les pseudo-modes en d{placement.
16 : *
17 : * PHRASE D'APPEL (EN GIBIANE):
18 : * ----------------------------
19 : *
20 : * SOLS = 'PSMO' RIG (MAS) MOD1 (TPODI) (CHP1 OU LCHP1)
21 : * (SEISME (UX) (UY) (UZ)) (FREQ XFREQ) ;
22 : *
23 : * OPERANDES ET RESULTATS:
24 : * -----------------------
25 : *
26 : * RIG 'RIGIDITE' matrice de rigidit{ de la structure.
27 : * MAS 'RIGIDITE' matrice de masse de la structure.
28 : * MOD1 'TABLE ' modes de la structure.
29 : * TPODI 'TABLE ' table de sous-type POINTS_DE_LIAISON, donnant
30 : * les point et normale de chaque choc.
31 : * CHP1 'CHPOINT ' description spatiale des chargements ou des
32 : * supports.
33 : * LCHP1 'LISTCHPO' description spatiale des chargements ou des
34 : * supports.
35 : * SEISME 'MOT ' mot cl{, indique que :
36 : * - soit la structure est soumise @
37 : * une acc{l{ration sismique d'ensemble.
38 : * - soit la structure est multisupport{e
39 : * avec un d{placement impos{ des supoorts.
40 : * UX 'MOT ' mot cl{, direction de l'excitation sismique
41 : * suivant X.
42 : * UY 'MOT ' mot cl{, direction de l'excitation sismique
43 : * suivant Y.
44 : * UZ 'MOT ' mot cl{, direction de l'excitation sismique
45 : * suivant Z.
46 : * FREQ 'MOT ' mot cl{, indique dans le cas ou la structure a
47 : * des modes de corps solide que l'utilisateur
48 : * veut imposer la fr{quence @ laquelle on
49 : * {tudiera la r{ponse de la structure.
50 : * XFREQ 'FLOTTANT' valeur de cette fr{quence.
51 : * SOLS 'TABLE ' objet TABLE de sous-type 'PSEUDO_MODE'
52 : * contenant les pseudo-modes.
53 : *
54 : * MODULES UTILISES:
55 : * -----------------
56 : *
57 : -INC CCOPTIO
58 : -INC CCREEL
59 : *-
60 : -INC SMRIGID
61 : -INC SMATTAC
62 : -INC SMCHPOI
63 : -INC SMELEME
64 : -INC SMLCHPO
65 : -INC SMSOLUT
66 : -INC SMSTRUC
67 : *
68 : * VARIABLES:
69 : * ----------
70 : *
71 : * DIR : direction de l'excitation sismique.
72 : * DIRECT(3) : tableau contenant les directions sismiques donn{es.
73 : * CORSOL = .TRUE. : la structure a des modes de corps solide.
74 : * SISMIQ = .TRUE. : excitation sismique.
75 : * FORCON = .TRUE. : force concentr{e.
76 : * STRUCM = .TRUE. : structure multisupport{e.
77 : *
78 : PARAMETER (LSEIS=3,LOPT1=1,LOPT2=1)
79 : CHARACTER*2 NSEISM(LSEIS),DIRECT(3),DIR
80 : CHARACTER*4 NOPTI1(LOPT1),COMP
81 : CHARACTER*6 NOPTI2(LOPT2)
82 : CHARACTER*8 TYPRET,CTYP,CHARRE
83 : CHARACTER*40 CMOT,MONMOT
84 : LOGICAL CORSOL,SISMIQ,FORCON,STRUCM,L0,L1
85 : *
86 : *
87 : * AUTEUR, DATE DE CREATION:
88 : * -------------------------
89 : *
90 : * Lionel VIVAN Juillet 1988
91 : *
92 : ************************************************************************
93 : *
94 : SEGMENT MTRAV
95 : REAL*8 FREQ(NBMODE),MN(NBMODE),MW2(NBMODE),
96 : & QX(NBMODE),QY(NBMODE),QZ(NBMODE)
97 : INTEGER DEPL(NBMODE)
98 : ENDSEGMENT
99 : *
100 : DATA NOPTI1/'FREQ'/
101 : DATA NOPTI2/'SEISME'/
102 : DATA NSEISM/'UX','UY','UZ'/
103 : CORSOL = .FALSE.
104 : SISMIQ = .FALSE.
105 : FORCON = .FALSE.
106 : STRUCM = .FALSE.
107 : DEUXPI = 2.D0 * XPI
108 : EPSI = 0.00001
109 : XFREQ = 0.D0
110 : NBCHP = 0
111 : LCH1 = 0
112 : ICH1 = 0
113 : IAT1 = 0
114 : DO 8 I =1,3
115 : DIRECT(I) = ' '
116 : 8 CONTINUE
117 : *
118 : * lecture des donn{es
119 : *
119 : CALL LIRMOT(NOPTI1,LOPT1,IMOT,0)
120 : IF (IMOT .EQ. 1) THEN
120 : CALL LIRREE(XFREQ,1,IRETOU)
121 : IF (XFREQ .LE. 0.D0) THEN
121 : CALL ERREUR(21)
122 : RETURN
123 : ENDIF
124 : CORSOL = .TRUE.
125 : ENDIF
126 : *
126 : CALL LIRMOT(NOPTI2,LOPT2,IMOT,0)
127 : IF (IMOT .EQ. 1) THEN
128 : SISMIQ = .TRUE.
129 : I = 0
130 : 10 CONTINUE
130 : CALL LIRMOT(NSEISM,LSEIS,IMOT,0)
131 : IF (IMOT .NE. 0) THEN
132 : IF (I .LE. 3) THEN
133 : I = I + 1
134 : DIRECT(I) = NSEISM(IMOT)
135 : GOTO 10
136 : ELSE
136 : CALL ERREUR(21)
137 : RETURN
138 : ENDIF
139 : ENDIF
140 : ENDIF
141 : *
141 : CALL QUETYP(CTYP,1,IRETOU)
142 : IF (CTYP(1:8).EQ.'RIGIDITE') GOTO 2000
143 : *+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+**+*+*+*+*+*+*+*+*+*+*+*+*
144 : * version appel{e @ disparaitre
145 : *+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+**+*+*+*+*+*+*+*+*+*+*+*+*
145 : CALL LIROBJ('STRUCTUR',ISTR,1,IRETOU)
146 : IF (IERR .NE. 0) RETURN
147 : *
147 : CALL LIROBJ('SOLUTION',IMOD,1,IRETOU)
148 : IF (IERR .NE. 0) RETURN
149 : *
149 : CALL LIROBJ('ATTACHE ',IATT,0,IRETOU)
150 : IF (IRETOU .EQ. 1) THEN
151 : IAT1 = 1
152 : ENDIF
153 : *
153 : CALL LIROBJ('CHPOINT ',ICHPT,0,IRETOU)
154 : IF (IRETOU .EQ. 0) THEN
154 : CALL LIROBJ('LISTCHPO',LCHPT,0,IRETOU)
155 : IF (IRETOU .EQ. 1) THEN
156 : LCH1 = 1
157 : ENDIF
158 : ELSE
159 : ICH1 = 1
160 : ENDIF
161 : IF (ICH1 .EQ. 1) THEN
161 : CALL ECROBJ('CHPOINT ',ICHPT)
161 : CALL SUITE1
162 : IF(IERR.NE.0) RETURN
162 : CALL LIROBJ('LISTCHPO',LCHPT,1,IRETOU)
163 : IF(IERR.NE.0) RETURN
164 : LCH1 = 1
165 : ENDIF
166 : *
167 : IF (LCH1 .EQ. 1) THEN
168 : IF ( SISMIQ ) THEN
169 : STRUCM = .TRUE.
170 : SISMIQ = .FALSE.
171 : ELSE
172 : FORCON = .TRUE.
173 : ENDIF
173 : CALL DIMEN2(LCHPT,NBCHP)
174 : IF (IERR.NE.0) RETURN
175 : ENDIF
176 : *
177 : * RECUPERATION DE LA MATRICE K ET DE LA MATRICE M
178 : *
178 : CALL EXTR10(ISTR,'RIGI',IRAI1)
179 : IF (IERR.NE.0) RETURN
179 : CALL EXTR10(ISTR,'MASS',IMAS1)
180 : IF (IERR.NE.0) RETURN
181 : *
182 : * REMPLISSAGE DE MTRAV
183 : *
184 : MSOLUT = IMOD
185 : SEGACT MSOLUT
186 : MSOLEN = MSOLIS(4)
187 : SEGACT MSOLEN
188 : NBMODE = ISOLEN(/1)
189 : *
190 : SEGINI MTRAV
191 : *
192 : DO 1940 I = 1,NBMODE
193 : FREQ(I) = XZERO
194 : MN(I) = XZERO
195 : MW2(I) = XZERO
196 : QX(I) = XZERO
197 : QY(I) = XZERO
198 : QZ(I) = XZERO
199 : DEPL(I) = 0
200 : 1940 CONTINUE
201 : *
202 : DO 1950 IM = 1,NBMODE
203 : MMODE = ISOLEN(IM)
204 : SEGACT MMODE
205 : XF = FMMODD(1)
206 : XMN = FMMODD(2)
207 : W2 = ( DEUXPI * XF ) ** 2
208 : FREQ(IM) = XF
209 : MN(IM) = XMN
210 : MW2(IM) = XMN * W2
211 : QX(IM) = FMMODD(3)
212 : QY(IM) = FMMODD(4)
213 : QZ(IM) = FMMODD(5)
214 : SEGDES MMODE
215 : 1950 CONTINUE
216 : SEGDES MSOLEN
217 : *
218 : MSOLEN = MSOLIS(5)
219 : SEGACT MSOLEN
220 : DO 1960 ID = 1,NBMODE
221 : DEPL(ID) = ISOLEN(ID)
222 : 1960 CONTINUE
223 : SEGDES MSOLEN
224 : *
225 : SEGDES MSOLUT
226 : *
227 : * CAS DES MODES DE CORPS SOLIDE
228 : * RECHERCHE DE FREQUENCE(S) NULLE(S) DANS L'OBJET SOLUTION
229 : *
230 : XF1 = 0.D0
231 : DO 1972 I = 1,NBMODE
232 : XFI = FREQ(I)
233 : IF (XFI .LT. EPSI) THEN
234 : CORSOL = .TRUE.
235 : ELSE
236 : IF (XF1 .EQ. 0.D0) XF1 =XFI
237 : ENDIF
238 : 1972 CONTINUE
239 : *
240 : IF ( CORSOL ) THEN
241 : IF (XFREQ .EQ. 0.D0) THEN
242 : * RECHERCHE DE LA 1-ERE FREQUENCE NON NULLE
243 : DO 1974 I = 1,NBMODE
244 : XFI = FREQ(I)
245 : IF ((XFI .LT. XF1) .AND.(XFI .GE. EPSI))THEN
246 : XF1 = XFI
247 : ENDIF
248 : 1974 CONTINUE
249 : XFREQ = XF1 / 2.D0
250 : ENDIF
251 : *
252 : IF ( IIMPI .GT. 0 ) THEN
253 : WRITE (IOIMP,998) ( FREQ(I),I=1,NBMODE)
254 : 998 FORMAT (/1X,'SBR PSMO LISTE DES FREQ ',/1X,10(E12.5,1X))
255 : WRITE ( IOIMP, 1002 ) XFREQ
256 : 1002 FORMAT ( /1X, 'SBR PSMO CORPS SOLIDES 1ERE FREQ*0.5 N.NUL'
257 : C ,' OU FREQ IMPO ',E12.5 )
258 : ENDIF
259 : W2 = (DEUXPI * XFREQ) ** 2
259 : CALL DECALE(IRAI1,IMAS1,W2,IRAID)
260 : IF (IERR.NE.0) RETURN
261 : *
262 : DO 19100 IM = 1,NBMODE
263 : W2I = ( DEUXPI * FREQ(IM) ) ** 2
264 : MW2(IM) = MN(IM) * ( W2I - W2 )
265 : 19100 CONTINUE
266 : *
267 : ELSE
268 : IRAID = IRAI1
269 : ENDIF
270 : *
271 : SEGDES MTRAV
272 : *
273 : NUME = NBMODE
274 : NBMOD1 = NBMODE + 1
275 : XFRST = 0.D0
276 : XMNST = 0.D0
277 : XQ1 = 0.D0
278 : XQ2 = 0.D0
279 : XQ3 = 0.D0
280 : ICHE1 = 0
281 : *
282 : * CAS DE L'ACCELERATION SISMIQUE D'ENSEMBLE
283 : *
284 : IF ( SISMIQ ) THEN
284 : CALL ECRCHA('MAIL')
284 : CALL ECROBJ('RIGIDITE',IRAID)
284 : CALL EXTRAI
285 : IF (IERR.NE.0) RETURN
285 : CALL LIROBJ('MAILLAGE',IMAIL,1,IRETOU)
286 : IF (IERR.NE.0) RETURN
287 : DO 1980 ID = 1,3
288 : DIR = DIRECT(ID)
289 : IF (DIR .NE. ' ') THEN
289 : CALL PSACCE(IRAID,IMAS1,IMAIL,MTRAV,DIR,ICHP1)
290 : N = 0
291 : SEGINI MJONCT
292 : IJONCT = MJONCT
293 : MJODDL = DIR
294 : MJOTYP = 'SEIS'
295 : MJOPOI = 0
296 : SEGDES MJONCT
297 : MCHPOI = ICHP1
298 : SEGACT MCHPOI
299 : IF (DIR .EQ. 'UX') THEN
300 : MOCHDE = 'EMSISEISMEX'
301 : ELSE IF (DIR .EQ. 'UY') THEN
302 : MOCHDE = 'EMSISEISMEY'
303 : ELSE
304 : MOCHDE = 'EMSISEISMEZ'
305 : ENDIF
306 : SEGDES MCHPOI
307 : NUME = NUME + 1
308 : IF (NUME .EQ. NBMOD1) THEN
308 : CALL MANUSO('PSEUMODE',NUME,XFRST,XMNST,XQ1,XQ2,XQ3,
309 : & ICHP1,ICHE1,IJONCT,ISOLS)
310 : ELSE
310 : CALL MANUSO('PSEUMODE',NUME,XFRST,XMNST,XQ1,XQ2,XQ3,
311 : & ICHP1,ICHE1,IJONCT,ISOL1)
311 : CALL FUSOLU(ISOLS,ISOL1,ISOL2)
312 : IF (IERR.NE.0) RETURN
312 : CALL DESOLU(ISOLS)
313 : IF (IERR.NE.0) RETURN
313 : CALL DESOLU(ISOL1)
314 : IF (IERR.NE.0) RETURN
315 : ISOLS = ISOL2
316 : ENDIF
317 : ENDIF
318 : 1980 CONTINUE
319 : ENDIF
320 : *
321 : * CAS DES FORCES CONCENTREES OU DE CHOCS
322 : *
323 : IF ( FORCON ) THEN
324 : DO 1920 IC = 1,NBCHP
324 : CALL EXTRA4(LCHPT,IC,ICHPT)
325 : IF (IERR.NE.0) RETURN
325 : CALL PSCHPT(IRAID,IMAS1,MTRAV,ICHPT,'FORC',ICHP1)
326 : N = 1
327 : SEGINI MJONCT
328 : IJONCT = MJONCT
329 : MJODDL = ' '
330 : MJOTYP = 'FORC'
331 : MJOPOI = 0
332 : IPCHJO(1) = ICHPT
333 : ISTRJO(1) = 0
334 : IPOSJO(1) = 0
335 : SEGDES MJONCT
336 : MCHPOI = ICHP1
337 : SEGACT MCHPOI
338 : MOCHDE = 'EMSIFORCECONCENTREE'
339 : SEGDES MCHPOI
340 : NUME = NUME + 1
341 : IF (NUME .EQ. NBMOD1) THEN
341 : CALL MANUSO('PSEUMODE',NUME,XFRST,XMNST,XQ1,XQ2,XQ3,
342 : & ICHP1,ICHE1,IJONCT,ISOLS)
343 : ELSE
343 : CALL MANUSO('PSEUMODE',NUME,XFRST,XMNST,XQ1,XQ2,XQ3,
344 : & ICHP1,ICHE1,IJONCT,ISOL1)
344 : CALL FUSOLU(ISOLS,ISOL1,ISOL2)
345 : IF (IERR.NE.0) RETURN
345 : CALL DESOLU(ISOLS)
346 : IF (IERR.NE.0) RETURN
346 : CALL DESOLU(ISOL1)
347 : IF (IERR.NE.0) RETURN
348 : ISOLS = ISOL2
349 : ENDIF
350 : 1920 CONTINUE
351 : ENDIF
352 : *
353 : * CAS DES FORCES DE CHOC
354 : *
355 : IF (IAT1 .EQ. 1) THEN
356 : MATTAC = IATT
357 : SEGACT MATTAC
358 : NSOUMA = LISATT(/1)
359 : DO 1932 IS =1,NSOUMA
360 : MSOUMA = LISATT(IS)
361 : SEGACT MSOUMA
362 : IF (ITYATT .NE. 'CHOC') THEN
363 : SEGDES MSOUMA
364 : GOTO 1932
365 : ENDIF
366 : MGEOCH = IGEOCH
367 : SEGACT MGEOCH
368 : MELEME = INORCH(1)
369 : SEGDES MGEOCH
370 : SEGACT MELEME
371 : NORM = NUM(1,1)
372 : SEGDES MELEME
373 : NJONCT = IATREL(/1)
374 : DO 1934 IJ =1,NJONCT
375 : MJONCT = IATREL(IJ)
376 : SEGACT MJONCT
377 : DO 1936 IJ2 = 1,2
378 : ISTR = ISTRJO(IJ2)
379 : IF (ISTR.NE.0) THEN
380 : MCHPOI = IPCHJO(IJ2)
381 : SEGACT MCHPOI
382 : MSOUPO = IPCHP(1)
383 : SEGDES MCHPOI
384 : SEGACT MSOUPO
385 : MELEME = IGEOC
386 : SEGDES MSOUPO
387 : SEGACT MELEME
388 : IPT = NUM(1,IJ2)
389 : SEGDES MELEME
390 : *
390 : CALL PSCHOC(IRAID,MTRAV,IPT,NORM,IJ2, ICHP1)
391 : N = 1
392 : SEGINI MJONC1
393 : IJONCT = MJONC1
394 : MJONC1.MJODDL = ' '
395 : MJONC1.MJOTYP = 'CHOC'
396 : MJONC1.MJOPOI = IPT
397 : MJONC1.IPCHJO(1) = 0
398 : MJONC1.ISTRJO(1) = ISTR
399 : MJONC1.IPOSJO(1) = 0
400 : SEGDES MJONC1
401 : *
402 : MCHPOI = ICHP1
403 : SEGACT MCHPOI
404 : MOCHDE = 'EMSIFORCEDECHOC'
405 : SEGDES MCHPOI
406 : *
407 : NUME = NUME + 1
408 : IF (NUME .EQ. NBMOD1) THEN
408 : CALL MANUSO('PSEUMODE',NUME,XFRST,XMNST,XQ1,
409 : & XQ2,XQ3,ICHP1,ICHE1,IJONCT,ISOLS)
410 : ELSE
410 : CALL MANUSO('PSEUMODE',NUME,XFRST,XMNST,XQ1,
411 : & XQ2,XQ3,ICHP1,ICHE1,IJONCT,ISOL1)
411 : CALL FUSOLU(ISOLS,ISOL1,ISOL2)
412 : IF (IERR.NE.0) RETURN
412 : CALL DESOLU(ISOLS)
413 : IF (IERR.NE.0) RETURN
413 : CALL DESOLU(ISOL1)
414 : IF (IERR.NE.0) RETURN
415 : ISOLS = ISOL2
416 : ENDIF
417 : ENDIF
418 : 1936 CONTINUE
419 : SEGDES MJONCT
420 : 1934 CONTINUE
421 : SEGDES MSOUMA
422 : 1932 CONTINUE
423 : SEGDES MATTAC
424 : ENDIF
425 : *
426 : * CAS DES STRUCTURES MULTISUPPORTEES
427 : *
428 : IF ( STRUCM ) THEN
429 : DO 1942 IC = 1,NBCHP
429 : CALL EXTRA4(LCHPT,IC,ICHPT)
430 : IF (IERR.NE.0) RETURN
430 : CALL PSCHPT(IRAID,IMAS1,MTRAV,ICHPT,'DEPL',ICHP1)
431 : N = 1
432 : SEGINI MJONCT
433 : IJONCT = MJONCT
434 : MJODDL = ' '
435 : MJOTYP = 'DEPL'
436 : MJOPOI = 0
437 : IPCHJO(1) = ICHPT
438 : ISTRJO(1) = 0
439 : IPOSJO(1) = 0
440 : SEGDES MJONCT
441 : MCHPOI = ICHP1
442 : SEGACT MCHPOI
443 : MOCHDE = 'EMSISTRUCTUREMULTISUPPORTEE'
444 : SEGDES MCHPOI
445 : NUME = NUME + 1
446 : IF (NUME .EQ. NBMOD1) THEN
446 : CALL MANUSO('PSEUMODE',NUME,XFRST,XMNST,XQ1,XQ2,XQ3,
447 : & ICHP1,ICHE1,IJONCT,ISOLS)
448 : ELSE
448 : CALL MANUSO('PSEUMODE',NUME,XFRST,XMNST,XQ1,XQ2,XQ3,
449 : & ICHP1,ICHE1,IJONCT,ISOL1)
449 : CALL FUSOLU(ISOLS,ISOL1,ISOL2)
450 : IF (IERR.NE.0) RETURN
450 : CALL DESOLU(ISOLS)
451 : IF (IERR.NE.0) RETURN
451 : CALL DESOLU(ISOL1)
452 : IF (IERR.NE.0) RETURN
453 : ISOLS = ISOL2
454 : ENDIF
455 : 1942 CONTINUE
456 : ENDIF
457 : *
458 : SEGSUP MTRAV
459 : *
459 : CALL ECROBJ('SOLUTION',ISOLS)
460 : *
461 : RETURN
462 : *+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+**+*++*+*+*
463 : * nouvelle version
464 : *+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+*+**+*++*+*+*
465 : 2000 CONTINUE
466 : IRAI1 = 0
467 : IMAS1 = 0
467 : 1 CALL LIROBJ('RIGIDITE',IRET,0,IRETOU)
468 : IF (IRETOU.NE.0) THEN
469 : MRIGID = IRET
470 : SEGACT,MRIGID
471 : IF (MTYMAT.EQ.'RIGIDITE') THEN
472 : IF (IRAI1.NE.0) THEN
473 : MOTERR(1:8)='RIGIDITE'
474 : MOTERR(9:16)='RIGIDITE'
474 : CALL ERREUR(130)
475 : * la matrice de rigidite a d{ja {t{ donn{e
476 : SEGDES,MRIGID
477 : RETURN
478 : ENDIF
479 : IRAI1 = MRIGID
480 : SEGDES,MRIGID
481 : IF (IMAS1.EQ.0) GOTO 1
482 : ELSE IF (MTYMAT.EQ.'MASSE') THEN
483 : IF (IMAS1.NE.0) THEN
484 : MOTERR(1:8)='RIGIDITE'
485 : MOTERR(9:16)='MASSE'
485 : CALL ERREUR(130)
486 : * la matrice de masse a d{ja {t{ donn{e
487 : SEGDES,MRIGID
488 : RETURN
489 : ENDIF
490 : IMAS1 = MRIGID
491 : SEGDES,MRIGID
492 : IF (IRAI1.EQ.0) GOTO 1
493 : ELSE
494 : MOTERR(1:8) = 'RIGIDITE'
495 : MOTERR(9:16) = MTYMAT
495 : CALL ERREUR(131)
496 : * on n'attend pas ce sous type de rigidit{
497 : SEGDES,MRIGID
498 : RETURN
499 : ENDIF
500 : ENDIF
501 : *
501 : CALL LIRTAB('BASE_DE_MODES',ITMOD,1,IRET)
502 : IF (IERR .NE. 0) RETURN
503 : *
503 : CALL LIRTAB('POINT_DE_LIAISON',ITLIA,0,IRETOU)
504 : IF (IRETOU .EQ. 1) THEN
505 : IAT1 = 1
506 : ENDIF
507 : *
507 : CALL LIROBJ('CHPOINT ',ICHPT,0,IRETOU)
508 : IF (IRETOU .EQ. 0) THEN
508 : CALL LIROBJ('LISTCHPO',LCHPT,0,IRETOU)
509 : IF (IRETOU .EQ. 1) THEN
510 : LCH1 = 1
511 : ENDIF
512 : ELSE
513 : ICH1 = 1
514 : ENDIF
515 : IF (ICH1 .EQ. 1) THEN
515 : CALL ECROBJ('CHPOINT ',ICHPT)
515 : CALL SUITE1
516 : IF(IERR.NE.0) RETURN
516 : CALL LIROBJ('LISTCHPO',LCHPT,1,IRETOU)
517 : IF(IERR.NE.0) RETURN
518 : LCH1 = 1
519 : ENDIF
520 : *
521 : IF (LCH1 .EQ. 1) THEN
522 : IF ( SISMIQ ) THEN
523 : STRUCM = .TRUE.
524 : SISMIQ = .FALSE.
525 : ELSE
526 : FORCON = .TRUE.
527 : ENDIF
527 : CALL DIMEN2(LCHPT,NBCHP)
528 : IF (IERR.NE.0) RETURN
529 : ENDIF
530 : *
531 : * remplissage de MTRAV
532 : *
532 : CALL DIMEN7(ITMOD,NBMODE)
533 : NBMODE = NBMODE - 2
534 : *
535 : SEGINI MTRAV
536 : DO 50 IM = 1,NBMODE
536 : CALL ACCTAB(ITMOD,'ENTIER',IM,X0,' ',L0,IP0,
537 : & 'TABLE',I1,X1,' ',L1,ITMK)
537 : CALL ACCTAB(ITMK,'MOT',I0,X0,'FREQUENCE',L0,IP0,
538 : & 'FLOTTANT',I1,XF,' ',L1,IP1)
538 : CALL ACCTAB(ITMK,'MOT',I0,X0,'MASSE_GENERALISEE',L0,IP0,
539 : & 'FLOTTANT',I1,XMN,' ',L1,IP1)
539 : CALL ACCTAB(ITMK,'MOT',I0,X0,'DEPLACEMENTS_GENERALISES',L0,IP0,
540 : & 'TABLE',I1,X1,' ',L1,ITDG)
540 : CALL ACCTAB(ITDG,'ENTIER',1,X0,' ',L0,IP0,
541 : & 'FLOTTANT',I1,XQX,' ',L1,IP1)
541 : CALL ACCTAB(ITDG,'ENTIER',2,X0,' ',L0,IP0,
542 : & 'FLOTTANT',I1,XQY,' ',L1,IP1)
542 : CALL ACCTAB(ITDG,'ENTIER',3,X0,' ',L0,IP0,
543 : & 'FLOTTANT',I1,XQZ,' ',L1,IP1)
543 : CALL ACCTAB(ITMK,'MOT',I0,X0,'DEFORMEE_MODALE',L0,IP0,
544 : & 'CHPOINT',I1,X1,' ',L1,ICHDM)
545 : W2 = ( DEUXPI * XF ) ** 2
546 : FREQ(IM) = XF
547 : MN(IM) = XMN
548 : MW2(IM) = XMN * W2
549 : QX(IM) = XQX
550 : QY(IM) = XQY
551 : QZ(IM) = XQZ
552 : DEPL(IM) = ICHDM
553 : 50 CONTINUE
554 : *
555 : * cas des modes de corps solide
556 : * recherche de fr{quence(s) nulle(s)
557 : *
558 : XF1 = 0.D0
559 : DO 72 I = 1,NBMODE
560 : XFI = FREQ(I)
561 : IF (XFI .LT. EPSI) THEN
562 : CORSOL = .TRUE.
563 : ELSE
564 : IF (XF1 .EQ. 0.D0) XF1 =XFI
565 : ENDIF
566 : 72 CONTINUE
567 : *
568 : IF ( CORSOL ) THEN
569 : IF (XFREQ .EQ. 0.D0) THEN
570 : * recherche de la 1-}re fr{quence non nulle
571 : DO 74 I = 1,NBMODE
572 : XFI = FREQ(I)
573 : IF ((XFI .LT. XF1) .AND.(XFI .GE. EPSI))THEN
574 : XF1 = XFI
575 : ENDIF
576 : 74 CONTINUE
577 : XFREQ = XF1 / 2.D0
578 : ENDIF
579 : *
580 : IF ( IIMPI .GT. 0 ) THEN
581 : WRITE (IOIMP,999) ( FREQ(I),I=1,NBMODE)
582 : 999 FORMAT (/1X,'SBR PSMO liste des freq ',/1X,10(E12.5,1X))
583 : WRITE ( IOIMP, 1000 ) XFREQ
584 : 1000 FORMAT ( /1X, 'SBR PSMO corps solides 1}re freq*0.5 n.nil'
585 : & ,' OU FREQ IMPO ',E12.5 )
586 : ENDIF
587 : W2 = (DEUXPI * XFREQ) ** 2
588 : IF (IMAS1.EQ.0) THEN
589 : MOTERR(1:8) = 'RIGIDITE'
590 : MOTERR(9:16) = 'MASSE '
590 : CALL ERREUR(131)
591 : SEGSUP,MTRAV
592 : RETURN
593 : ENDIF
593 : CALL DECALE(IRAI1,IMAS1,W2,IRAID)
594 : IF (IERR.NE.0) RETURN
595 : *
596 : DO 100 IM = 1,NBMODE
597 : W2I = ( DEUXPI * FREQ(IM) ) ** 2
598 : MW2(IM) = MN(IM) * ( W2I - W2 )
599 : 100 CONTINUE
600 : *
601 : ELSE
602 : IRAID = IRAI1
603 : ENDIF
604 : *
605 : SEGDES MTRAV
606 : *
607 : * cr{ation de la table de sortie
608 : *
608 : CALL CRTABL(ITPSMO)
608 : CALL ECCTAB(ITPSMO,'MOT',I0,X0,'SOUSTYPE',L0,IP0,
609 : & 'MOT',I1,X1,'PSEUDO_MODE',L1,IP1)
610 : IPSMO = 0
611 : *
612 : * cas de l'acceleration sismique d'ensemble
613 : *
614 : IF ( SISMIQ ) THEN
615 : IF (IRAID.EQ.0) THEN
616 : MOTERR(1:8)='RIGIDITE'
617 : MOTERR(9:16)='RAIDEUR'
617 : CALL ERREUR(79)
618 : SEGSUP,MTRAV
619 : RETURN
620 : ENDIF
621 : IF (IMAS1.EQ.0) THEN
622 : MOTERR(1:8)='RIGIDITE'
623 : MOTERR(9:16)='MASSE'
623 : CALL ERREUR(79)
624 : SEGSUP,MTRAV
625 : RETURN
626 : ENDIF
626 : CALL ECRCHA('MAIL')
626 : CALL ECROBJ('RIGIDITE',IRAID)
626 : CALL EXTRAI
627 : IF (IERR.NE.0) RETURN
627 : CALL LIROBJ('MAILLAGE',IMAIL,1,IRETOU)
628 : IF (IERR.NE.0) RETURN
629 : DO 80 ID = 1,3
630 : DIR = DIRECT(ID)
631 : IF (DIR .NE. ' ') THEN
631 : CALL PSACCE(IRAID,IMAS1,IMAIL,MTRAV,DIR,ICHP1)
632 : MCHPOI = ICHP1
633 : SEGACT MCHPOI*MOD
634 : IF (DIR .EQ. 'UX') THEN
635 : MOCHDE = 'EMSISEISMEX'
636 : IENT = 1
637 : ELSE IF (DIR .EQ. 'UY') THEN
638 : MOCHDE = 'EMSISEISMEY'
639 : IENT = 2
640 : ELSE
641 : MOCHDE = 'EMSISEISMEZ'
642 : IENT = 3
643 : ENDIF
644 : SEGDES MCHPOI
644 : CALL CRTABL(ITSEIS)
644 : CALL ECCTAB(ITSEIS,'MOT',I0,X0,'SOUSTYPE',L0,IP0,
645 : & 'MOT',I1,X1,'PSMO_SEIS',L1,IP1)
645 : CALL ECCTAB(ITSEIS,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
646 : & 'CHPOINT',I1,X1,' ',L1,ICHP1)
646 : CALL ECCTAB(ITSEIS,'MOT',I0,X0,'DIRECTION',L0,IP0,
647 : & 'ENTIER',IENT,X1,' ',L1,IP1)
648 : IPSMO = IPSMO + 1
648 : CALL ECCTAB(ITPSMO,'ENTIER',IPSMO,X0,' ',L0,IP0,
649 : & 'TABLE',I1,X1,' ',L1,ITSEIS)
650 : ENDIF
651 : 80 CONTINUE
652 : ENDIF
653 : *
654 : * cas des forces concentr{es
655 : *
656 : IF ( FORCON ) THEN
657 : IF (IRAID.EQ.0) THEN
658 : MOTERR(1:8)='RIGIDITE'
659 : MOTERR(9:16)='RAIDEUR'
659 : CALL ERREUR(79)
660 : SEGSUP,MTRAV
661 : RETURN
662 : ENDIF
663 : DO 20 IC = 1,NBCHP
663 : CALL EXTRA4(LCHPT,IC,ICHPT)
664 : IF (IERR.NE.0) RETURN
664 : CALL PSCHPT(IRAID,IMAS1,MTRAV,ICHPT,'FORC',ICHP1)
665 : MCHPOI = ICHP1
666 : SEGACT MCHPOI*MOD
667 : MOCHDE = 'EMSIFORCECONCENTREE'
668 : SEGDES MCHPOI
668 : CALL CRTABL(ITFORC)
668 : CALL ECCTAB(ITFORC,'MOT',I0,X0,'SOUSTYPE',L0,IP0,
669 : & 'MOT',I1,X1,'PSMO_FORC',L1,IP1)
669 : CALL ECCTAB(ITFORC,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
670 : & 'CHPOINT',I1,X1,' ',L1,ICHP1)
670 : CALL ECCTAB(ITFORC,'MOT',I0,X0,'CHAMP_BASE_B',L0,IP0,
671 : & 'CHPOINT',I1,X1,' ',L1,ICHPT)
671 : CALL PROJTA(ICHPT,ITMOD,ICHPR)
671 : CALL ECCTAB(ITFORC,'MOT',I0,X0,'CHAMP_BASE_A',L0,IP0,
672 : & 'CHPOINT',I1,X1,' ',L1,ICHPR)
673 : IPSMO = IPSMO + 1
673 : CALL ECCTAB(ITPSMO,'ENTIER',IPSMO,X0,' ',L0,IP0,
674 : & 'TABLE',I1,X1,' ',L1,ITFORC)
675 : 20 CONTINUE
676 : ENDIF
677 : *
678 : * cas des forces de choc
679 : *
680 : IF (IAT1 .EQ. 1) THEN
681 : IF (IRAID.EQ.0) THEN
682 : MOTERR(1:8)='RIGIDITE'
683 : MOTERR(9:16)='RAIDEUR'
683 : CALL ERREUR(79)
684 : SEGSUP,MTRAV
685 : RETURN
686 : ENDIF
687 : IL = 0
688 : 32 CONTINUE
689 : IL = IL + 1
690 : TYPRET = ' '
690 : CALL ACCTAB(ITLIA,'ENTIER',IL,X0,' ',L0,IP0,
691 : & TYPRET,I1,X1,CHARRE,L1,ITLLL)
692 : IF (ITLLL.NE.0 .AND. TYPRET.EQ.'TABLE ') THEN
692 : CALL ACCTAB(ITLLL,'MOT',I1,X0,'POINT',L0,IP0,
693 : & 'POINT',I1,X1,' ',L1,IPS)
693 : CALL ACCTAB(ITLLL,'MOT',I1,X0,'NORMALE',L0,IP0,
694 : & 'POINT',I1,X1,' ',L1,IPN)
694 : CALL PSCHOC(IRAID,MTRAV,IPS,IPN,1,ICHP1)
695 : MCHPOI = ICHP1
696 : SEGACT MCHPOI*MOD
697 : MOCHDE = 'EMSIFORCEDECHOC'
698 : SEGDES MCHPOI
698 : CALL CRTABL(ILIAI)
698 : CALL ECCTAB(ILIAI,'MOT',I0,X0,'SOUSTYPE',L0,IP0,
699 : & 'MOT',I1,X1,'PSMO_LIAI',L1,IP1)
699 : CALL ECCTAB(ILIAI,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
700 : & 'CHPOINT',I1,X1,' ',L1,ICHP1)
700 : CALL ECCTAB(ILIAI,'MOT',I0,X0,'POINT',L0,IP0,
701 : & 'POINT',I1,X1,' ',L1,IPS)
701 : CALL ECCTAB(ILIAI,'MOT',I0,X0,'NORMALE',L0,IP0,
702 : & 'POINT',I1,X1,' ',L1,IPN)
703 : IPSMO = IPSMO + 1
703 : CALL ECCTAB(ITPSMO,'ENTIER',IPSMO,X0,' ',L0,IP0,
704 : & 'TABLE',I1,X1,' ',L1,ILIAI)
705 : GOTO 32
706 : ENDIF
707 : ENDIF
708 : *
709 : * cas des structures multisupport{es
710 : *
711 : IF ( STRUCM ) THEN
712 : IF (IRAID.EQ.0) THEN
713 : MOTERR(1:8)='RIGIDITE'
714 : MOTERR(9:16)='RAIDEUR'
714 : CALL ERREUR(79)
715 : SEGSUP,MTRAV
716 : RETURN
717 : ENDIF
718 : IF (IMAS1.EQ.0) THEN
719 : MOTERR(1:8)='RIGIDITE'
720 : MOTERR(9:16)='RAIDEUR'
720 : CALL ERREUR(79)
721 : SEGSUP,MTRAV
722 : RETURN
723 : ENDIF
724 : DO 42 IC = 1,NBCHP
724 : CALL EXTRA4(LCHPT,IC,ICHPT)
725 : IF (IERR.NE.0) RETURN
725 : CALL PSCHPT(IRAID,IMAS1,MTRAV,ICHPT,'DEPL',ICHP1)
726 : MCHPOI = ICHP1
727 : SEGACT MCHPOI*MOD
728 : MOCHDE = 'EMSISTRUCTUREMULTISUPPORTEE'
729 : SEGDES MCHPOI
729 : CALL CRTABL(ITMULT)
729 : CALL ECCTAB(ITMULT,'MOT',I0,X0,'SOUSTYPE',L0,IP0,
730 : & 'MOT',I1,X1,'PSMO_DEPL',L1,IP1)
730 : CALL ECCTAB(ITMULT,'MOT',I0,X0,'DEPLACEMENT',L0,IP0,
731 : & 'CHPOINT',I1,X1,' ',L1,ICHP1)
731 : CALL ECCTAB(ITMULT,'MOT',I0,X0,'CHAMP_BASE_B',L0,IP0,
732 : & 'CHPOINT',I1,X1,' ',L1,ICHPT)
732 : CALL PROJTA(ICHPT,ITMOD,ICHPR)
732 : CALL ECCTAB(ITMULT,'MOT',I0,X0,'CHAMP_BASE_A',L0,IP0,
733 : & 'CHPOINT',I1,X1,' ',L1,ICHPR)
734 : IPSMO = IPSMO + 1
734 : CALL ECCTAB(ITPSMO,'ENTIER',IPSMO,X0,' ',L0,IP0,
735 : & 'TABLE',I1,X1,' ',L1,ITMULT)
736 : 42 CONTINUE
737 : ENDIF
738 : *
739 : SEGSUP MTRAV
740 : *
740 : CALL ECROBJ('TABLE',ITPSMO)
741 : *
742 : END
743 :
744 :
745 :
746 :
747 :
748 :
749 :
750 :
751 :
752 :
753 :
© Cast3M 2003 - All rights reserved.
Disclaimer