1 : C VIBRAC SOURCE BP208322 13/07/25 21:15:07 7804
2 : SUBROUTINE VIBRAC
3 : *
4 : *****************************************************************************
5 : * RESOLUTION DE M X'' + C X' + K X = 0 *
6 : * PAR L'ALGORITHME DU QZ *
7 : * *
8 : * RESOLUTION DE M X'' + C X' + K X = Fharmonique *
9 : * PAR APPEL A L'OPERATEUR RESOU *
10 : * _________________________________________________________________________ *
11 : * *
12 : * DATE : le 29 Novembre 1996 *
13 : * AUTEUR : VIBC calcul des modes Nicolas BENECH le 24/02/95 *
14 : * option 'BALOU' Jerome CHARPENTIER le 29/11/96 *
15 : * amelioration rapidité VIBC 'MODES' BP208322 16/12/2008 *
16 : * _________________________________________________________________________ *
17 : * *
18 : * MODULE(S) APPELANT(S) : *
19 : * *
20 : * MODULE(S) APPELE(S) : LIROBJ, LIRMOT, QZTRIR, QZADRG, QZCONS, *
21 : * QZHESS, QZREDU, QZVALP, QZVECP, QZBASC, *
22 : * QZREST, ECROBJ, QZCON2, RECOBAL. *
23 : * *
24 : * _________________________________________________________________________ *
25 : * *
26 : * EN ENTREE : *
27 : * IMOT : option 'BALOU' *
28 : * IPMAS, IPRIG, (IPAMO): rigidités Masse, Raideur, (Amortissement), *
29 : * projetées sur une base de modes reels. *
30 : * (IBASR): base de modes reels ayant servie a la projection. *
31 : * Standard : *
32 : * ('MATA'), ('MATB'): option pour recuperer les matrices *
33 : * | - K | 0 | | C | M | *
34 : * A = | ----+---- | B = | ----+---- | *
35 : * | 0 | M | | M | 0 | *
36 : * !!! dans ce cas IBASR est ignoree !!! *
37 : * *
38 : * Option 'BALOU' : *
39 : * IFPROJ : force excitatrice projetée sur la base réelle *
40 : * | -w^2 * M + K | -w * C | *
41 : * A = |--------------+--------------| *
42 : * | w * C | -w^2 * M + K | *
43 : * resolution de A . q = F *
44 : * _________________________________________________________________________ *
45 : * *
46 : * EN SORTIE : *
47 : * Standard : *
48 : * IBASC: base de modes propres complexes, physique si IBASR est *
49 : * prise en compte. *
50 : * (IPRI1), (IPRI2): matrices A et B resp. si elles sont demandees. *
51 : * *
52 : * Option 'BALOU' : *
53 : * MCHPO2 : reponse (partie reelle) *
54 : * MCHPO4 : reponse (partie imaginaire) *
55 : *****************************************************************************
56 : *
57 : IMPLICIT INTEGER(I-N)
58 : IMPLICIT REAL*8 (A-H,O-Z)
59 : DATA ZERO / 0.0D0 /
60 : INTEGER ERR, NUMAFF
61 : LOGICAL CALV, RESTIT, AFFICH
62 : REAL*8 XPREC1
63 : c PARAMETER (LMOOPT=3)
64 : c CHARACTER*5 MOOPT(LMOOPT)
65 : c DATA MOOPT/'BALOU','AFFI1','AFFI2'/
66 : PARAMETER (LMOOPT=1)
67 : CHARACTER*5 MOOPT(LMOOPT)
68 : DATA MOOPT/'BALOU'/
69 : CHARACTER*4 MOOPT1(1),MOOPT2(1)
70 : DATA MOOPT1/'AFF1'/
71 : DATA MOOPT2/'AFF2'/
72 : * ----------------------------------------------------
73 : -INC CCOPTIO
74 : -INC SMRIGID
75 : * ----------------------------------------------------
76 : c POINTEUR MAT1.MRIGID, MAT2.MRIGID, MATA.MRIGID, MATB.MRIGID
77 : POINTEUR MAT1.MRIGID, MAT2.MRIGID
78 : POINTEUR CHPO1.MCHPOI, CHPO2.MCHPOI, CHPO4.MCHPOI
79 : POINTEUR MATA.XMATRI, MATB.XMATRI, MATZ.XMATRI
80 : * ----------------------------------------------------
81 : CALV = .TRUE.
82 : AFFICH = .FALSE.
83 : * ----------------------------------------------------
83 : CALL LIRMOT(MOOPT,LMOOPT,IMOT,0)
84 : *
84 : CALL LIROBJ('RIGIDITE',IPMAS,1,IRET)
85 : IF (IERR.NE.0) RETURN
85 : CALL LIROBJ('RIGIDITE',IPRIG,1,IRET)
86 : IF (IERR.NE.0) RETURN
86 : CALL LIROBJ('RIGIDITE',IPAMO,0,IRET)
87 : IF (IERR.NE.0) RETURN
87 : CALL LIROBJ('TABLE ',IBASR,0,IRET)
88 : IF (IERR.NE.0) RETURN
89 : RESTIT = (IRET.EQ.1)
90 : *
91 : * ----------------------------------------------------
91 : CALL QZTRIR(IPMAS, IPRIG, IPAMO)
92 : * ----------------------------------------------------
92 : CALL QZADRG(IPMAS,IPM)
93 : * ----------------------------------------------------
93 : CALL QZADRG(IPRIG,IPR)
94 : * ----------------------------------------------------
95 : IF (IPAMO.NE.0) THEN
95 : CALL QZADRG(IPAMO,IPA)
96 : IF (IERR.NE.0) RETURN
97 : ELSE
98 : IPA=0
99 : ENDIF
100 : IF (IMOT.EQ.1) GOTO 1010
101 : *
102 : * ----------------------------------------------------
102 : CALL QZCONS(IPM,IPR,IPA,MATA,MATB,MELEME,MCOMP,(.NOT.RESTIT))
103 : IF (IERR.NE.0) RETURN
104 : * ----------------------------------------------------
104 : CALL QZHESS(MATA,MATB,CALV,IPRI3)
105 : IF (IERR.NE.0) RETURN
106 : XPREC1 = ZERO
106 : CALL LIRREE(XPREC1,0,IRETOU)
106 : CALL QZREDU(MATA,MATB,XPREC1,CALV,IPRI3,ERR)
107 : IF (IERR.NE.0) RETURN
108 : IF (ERR.NE.0) WRITE (*,*) 'Mode ',ERR,' : trop d iterations !'
109 : &,' L exécution continu ...'
110 : * ----------------------------------------------------
110 : CALL QZVALP(MATA,MATB,IPAR,IPAI,IPBE,CALV,IPRI3)
111 : IF (IERR.NE.0) RETURN
112 : * ----------------------------------------------------
112 : CALL QZVECP(MATA,MATB,IPAR,IPAI,IPBE,IPRI3)
113 : IF (IERR.NE.0) RETURN
114 : * ----------------------------------------------------
114 : CALL QZBASC(IPAR,IPAI,IPBE,IPRI3,MELEME,MCOMP,IBASC,ERR)
115 : IF (IERR.NE.0) RETURN
116 : * ----------------------------------------------------
117 : IF (RESTIT) THEN
117 : CALL QZREST(IBASR, IBASC, IBASC)
118 : ENDIF
119 : * ----------------------------------------------------
119 : CALL ECROBJ('TABLE ',IBASC)
120 : GOTO 1000
121 : * ----------------------------------------------------
122 : *
123 : * ----------------------------------------------------
123 : 1010 CALL LIROBJ('CHPOINT ',IFPROJ,1,IRET)
124 : IF (IERR.NE.0) RETURN
124 : CALL LIRREE(ROMEGA,1,IRET)
125 : IF (IERR.NE.0) RETURN
125 : CALL LIRMOT(MOOPT1,1,IMOT1,0)
125 : CALL LIRMOT(MOOPT2,1,IMOT2,0)
125 : CALL QZCON2(IPM,IPR,IPA,ROMEGA,MAT1,IFPROJ)
126 : IF (IERR.NE.0) RETURN
127 : IF (IMOT1.EQ.1) THEN
127 : CALL PRRIGI(MAT1,0)
128 : ENDIF
128 : CALL ECROBJ('RIGIDITE',MAT1)
128 : CALL ECROBJ('CHPOINT ',IFPROJ)
128 : CALL RESOU
128 : CALL LIROBJ('CHPOINT ',CHPO1,1,IRET)
129 : IF (IMOT2.EQ.1) THEN
129 : CALL ECCHPO(CHPO1,0)
130 : ENDIF
130 : CALL RECOBAL(IBASR,CHPO1,CHPO2,CHPO4)
130 : CALL ECROBJ('CHPOINT ',CHPO2)
130 : CALL ECROBJ('CHPOINT ',CHPO4)
131 : *
132 : * ----------------------------------------------------
133 : 1000 RETURN
134 : END
135 :
136 :
137 :
138 :
139 :
140 :
141 :
142 :
143 :
144 :
145 :
© Cast3M 2003 - All rights reserved.
Disclaimer