C VIBRAC SOURCE BP208322 13/07/25 21:15:07 7804 SUBROUTINE VIBRAC * ***************************************************************************** * RESOLUTION DE M X'' + C X' + K X = 0 * * PAR L'ALGORITHME DU QZ * * * * RESOLUTION DE M X'' + C X' + K X = Fharmonique * * PAR APPEL A L'OPERATEUR RESOU * * _________________________________________________________________________ * * * * DATE : le 29 Novembre 1996 * * AUTEUR : VIBC calcul des modes Nicolas BENECH le 24/02/95 * * option 'BALOU' Jerome CHARPENTIER le 29/11/96 * * amelioration rapidité VIBC 'MODES' BP208322 16/12/2008 * * _________________________________________________________________________ * * * * MODULE(S) APPELANT(S) : * * * * MODULE(S) APPELE(S) : LIROBJ, LIRMOT, QZTRIR, QZADRG, QZCONS, * * QZHESS, QZREDU, QZVALP, QZVECP, QZBASC, * * QZREST, ECROBJ, QZCON2, RECOBAL. * * * * _________________________________________________________________________ * * * * EN ENTREE : * * IMOT : option 'BALOU' * * IPMAS, IPRIG, (IPAMO): rigidités Masse, Raideur, (Amortissement), * * projetées sur une base de modes reels. * * (IBASR): base de modes reels ayant servie a la projection. * * Standard : * * ('MATA'), ('MATB'): option pour recuperer les matrices * * | - K | 0 | | C | M | * * A = | ----+---- | B = | ----+---- | * * | 0 | M | | M | 0 | * * !!! dans ce cas IBASR est ignoree !!! * * * * Option 'BALOU' : * * IFPROJ : force excitatrice projetée sur la base réelle * * | -w^2 * M + K | -w * C | * * A = |--------------+--------------| * * | w * C | -w^2 * M + K | * * resolution de A . q = F * * _________________________________________________________________________ * * * * EN SORTIE : * * Standard : * * IBASC: base de modes propres complexes, physique si IBASR est * * prise en compte. * * (IPRI1), (IPRI2): matrices A et B resp. si elles sont demandees. * * * * Option 'BALOU' : * * MCHPO2 : reponse (partie reelle) * * MCHPO4 : reponse (partie imaginaire) * ***************************************************************************** * IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) DATA ZERO / 0.0D0 / INTEGER ERR, NUMAFF LOGICAL CALV, RESTIT, AFFICH REAL*8 XPREC1 c PARAMETER (LMOOPT=3) c CHARACTER*5 MOOPT(LMOOPT) c DATA MOOPT/'BALOU','AFFI1','AFFI2'/ PARAMETER (LMOOPT=1) CHARACTER*5 MOOPT(LMOOPT) DATA MOOPT/'BALOU'/ CHARACTER*4 MOOPT1(1),MOOPT2(1) DATA MOOPT1/'AFF1'/ DATA MOOPT2/'AFF2'/ * ---------------------------------------------------- -INC CCOPTIO -INC SMRIGID * ---------------------------------------------------- c POINTEUR MAT1.MRIGID, MAT2.MRIGID, MATA.MRIGID, MATB.MRIGID POINTEUR MAT1.MRIGID, MAT2.MRIGID POINTEUR CHPO1.MCHPOI, CHPO2.MCHPOI, CHPO4.MCHPOI POINTEUR MATA.XMATRI, MATB.XMATRI, MATZ.XMATRI * ---------------------------------------------------- CALV = .TRUE. AFFICH = .FALSE. * ---------------------------------------------------- CALL LIRMOT(MOOPT,LMOOPT,IMOT,0) * CALL LIROBJ('RIGIDITE',IPMAS,1,IRET) IF (IERR.NE.0) RETURN CALL LIROBJ('RIGIDITE',IPRIG,1,IRET) IF (IERR.NE.0) RETURN CALL LIROBJ('RIGIDITE',IPAMO,0,IRET) IF (IERR.NE.0) RETURN CALL LIROBJ('TABLE ',IBASR,0,IRET) IF (IERR.NE.0) RETURN RESTIT = (IRET.EQ.1) * * ---------------------------------------------------- CALL QZTRIR(IPMAS, IPRIG, IPAMO) * ---------------------------------------------------- CALL QZADRG(IPMAS,IPM) * ---------------------------------------------------- CALL QZADRG(IPRIG,IPR) * ---------------------------------------------------- IF (IPAMO.NE.0) THEN CALL QZADRG(IPAMO,IPA) IF (IERR.NE.0) RETURN ELSE IPA=0 ENDIF IF (IMOT.EQ.1) GOTO 1010 * * ---------------------------------------------------- CALL QZCONS(IPM,IPR,IPA,MATA,MATB,MELEME,MCOMP,(.NOT.RESTIT)) IF (IERR.NE.0) RETURN * ---------------------------------------------------- CALL QZHESS(MATA,MATB,CALV,IPRI3) IF (IERR.NE.0) RETURN XPREC1 = ZERO CALL LIRREE(XPREC1,0,IRETOU) CALL QZREDU(MATA,MATB,XPREC1,CALV,IPRI3,ERR) IF (IERR.NE.0) RETURN IF (ERR.NE.0) WRITE (*,*) 'Mode ',ERR,' : trop d iterations !' &,' L exécution continu ...' * ---------------------------------------------------- CALL QZVALP(MATA,MATB,IPAR,IPAI,IPBE,CALV,IPRI3) IF (IERR.NE.0) RETURN * ---------------------------------------------------- CALL QZVECP(MATA,MATB,IPAR,IPAI,IPBE,IPRI3) IF (IERR.NE.0) RETURN * ---------------------------------------------------- CALL QZBASC(IPAR,IPAI,IPBE,IPRI3,MELEME,MCOMP,IBASC,ERR) IF (IERR.NE.0) RETURN * ---------------------------------------------------- IF (RESTIT) THEN CALL QZREST(IBASR, IBASC, IBASC) ENDIF * ---------------------------------------------------- CALL ECROBJ('TABLE ',IBASC) GOTO 1000 * ---------------------------------------------------- * * ---------------------------------------------------- 1010 CALL LIROBJ('CHPOINT ',IFPROJ,1,IRET) IF (IERR.NE.0) RETURN CALL LIRREE(ROMEGA,1,IRET) IF (IERR.NE.0) RETURN CALL LIRMOT(MOOPT1,1,IMOT1,0) CALL LIRMOT(MOOPT2,1,IMOT2,0) CALL QZCON2(IPM,IPR,IPA,ROMEGA,MAT1,IFPROJ) IF (IERR.NE.0) RETURN IF (IMOT1.EQ.1) THEN CALL PRRIGI(MAT1,0) ENDIF CALL ECROBJ('RIGIDITE',MAT1) CALL ECROBJ('CHPOINT ',IFPROJ) CALL RESOU CALL LIROBJ('CHPOINT ',CHPO1,1,IRET) IF (IMOT2.EQ.1) THEN CALL ECCHPO(CHPO1,0) ENDIF CALL RECOBAL(IBASR,CHPO1,CHPO2,CHPO4) CALL ECROBJ('CHPOINT ',CHPO2) CALL ECROBJ('CHPOINT ',CHPO4) * * ---------------------------------------------------- 1000 RETURN END