C QZBASC SOURCE BP208322 12/10/03 21:15:18 7517 SUBROUTINE QZBASC (ALFR, ALFI, BETA, MATZ, MELEME, MCOMP, & IPBC,ERR) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) * ***************************************************************************** * CREATION D'UNE BASE DE MODES PROPRES COMPLEXES POUR VIBC * _________________________________________________________________________ * * * DATE : 13 avril 1995 * AUTEUR : Nicolas BENECH * _________________________________________________________________________ * * * MODULE(S) APPELANT(S) : VIBRAC * * * MODULE(S) APPELE(S) : CRTABL, ACCTAB, ECCTAB, CREPO1, MUCHPO, EPSLON * _________________________________________________________________________ * * * EN ENTREE : * -ALFR : partie reelle des valeurs propres * -ALFI : partie imaginaire des valeurs propres * -BETA : denominateur (reel) des valeurs propres * (denominateur nul --> valeur propre infinie) * -MATZ : vecteurs propres complexes * -MELEME : maillage support des chpoints * -MCOMP : liste des composantes des chpoints * _________________________________________________________________________ * * * EN SORTIE : * -IPBC : base de modes complexes * _________________________________________________________________________ * * * REMARQUE : la variable SEUIL definie au début des données générales * permet d'identifier les valeurs propres infinies, et * d'annuler le mode correspondant. * Sa valeur a ete fixee a 100 x EPSLON(1.0D0) pour le moment ***************************************************************************** * -INC CCREEL *- -INC CCOPTIO -INC SMELEME -INC SMLCHPO -INC SMLMOTS -INC SMCHPOI -INC SMRIGID -INC SMTABLE * REAL*8 XVAL,SEUIL INTEGER I, J, K, IC, NUMAFF,ERR LOGICAL MODANN, MODREL, AFFICH,CONV * POINTEUR ALFR.XMATRI, ALFI.XMATRI, BETA.XMATRI POINTEUR MATZ.XMATRI POINTEUR MCOMP.MLMOTS * *----- Ecriture des messages pour verification * NUMAFF = 22 AFFICH = ((MOD(IIMPI,NUMAFF) .EQ. 0) .AND. (IIMPI .NE. 0)) * AFFICH = .TRUE. * ******************************************* * Donnees generales * ******************************************* c SEGACT, MATZ, ALFR,ALFI,BETA * IF (AFFICH) WRITE (*,*) 'Extraction des donnees generales...' * * seuil pour le denominateur d'une valeur propre * SEUIL = (EPSLON(1.0D0)*100) SEUIL = 1.D-99 * nombre de modes ... NBMOD1=ALFR.RE(/2) * nombre de points ... SEGACT , MELEME NBP1=MELEME.NUM(/2) SEGDES , MELEME N=NBP1 * nombre de composantes ... SEGACT, MCOMP NC = MCOMP.MOTS(/2) c SEGDES, MCOMP IF (AFFICH) THEN WRITE (*,*) 'XPI = ',XPI WRITE (*,*) 'NC = ',NC WRITE (*,*) 'NBP1 = N = ', N WRITE (*,*) 'EPSLON = ',EPSLON(1.0D0) ENDIF * ******************************************* * Creation de la table BASE_DE_MODES * ******************************************* * IF (AFFICH) WRITE (*,*) 'Creation de la table BASE_DE_MODES...' * CALL CRTABL(IPTAB2) CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0, & 'MOT',0,0.0D0,'BASE_DE_MODES',.TRUE.,0) CALL ECCTAB(IPTAB2,'MOT',0,0.0D0,'MAILLAGE',.TRUE.,0, & 'MAILLAGE',0,0.0D0,' ',.TRUE.,MELEME) * ******************************************* * Boucle sur les Modes * ******************************************* * I=1 80 IF (I .GT. NBMOD1) GOTO 20 * IF (AFFICH) WRITE (*,*) 'Mode ',I * MODREL = (ABS(ALFI.RE(1,I,1)).EQ. 0.0D0) IF (AFFICH) THEN IF (MODREL) THEN WRITE (*,*) 'MODE REEL' ELSE WRITE (*,*) 'MODE COMPLEXE' ENDIF ENDIF * * ---- frequence infinie ? * MODANN = (ABS(BETA.RE(1,I,1)).LT.SEUIL) * ---- oui IF (MODANN) THEN 90 WRITE (*,*) 'Attention !!! Mode ',I, & ' annule : frequence infinie.' CALL CRTABL(MTAB1) CALL ECCTAB(MTAB1,'MOT',0,0.0D0,'SOUSTYPE', .TRUE.,0, & 'MOT',0,0.0D0,'MODE_ANNULE',.TRUE.,0) CALL ECCTAB(IPTAB2,'ENTIER',I,0.0D0,' ',.TRUE.,0, & 'TABLE', 0, 0.0D0,' ',.TRUE.,MTAB1) IF (.NOT. MODREL) THEN MODREL = .TRUE. I = I + 1 GO TO 90 ENDIF * ---- non ELSE * *------- Deformees reelle (1) et imaginaire (2) du mode i * * Creation de MPOVA1 et MPOVA2 IF (AFFICH) WRITE (*,*) 'Calcul des deformees ...' SEGINI, MPOVA1 SEGINI, MPOVA2 DO 30, IC=1,NC DO 40, K=1,NBP1 MPOVA1.VPOCHA(K,IC)=MATZ.RE((K-1)*NC+IC,I,1) * IF (MODREL) THEN * MPOVA2.VPOCHA(K,IC)=0 * ELSE * MPOVA2.VPOCHA(K,IC)=MATZ.RE((K-1)*NC+IC,I+1,1) * ENDIF IF (.not.MODREL) & MPOVA2.VPOCHA(K,IC)=MATZ.RE((K-1)*NC+IC,I+1,1) 40 CONTINUE 30 CONTINUE SEGDES, MPOVA1 SEGDES, MPOVA2 * * Creation de MSOUP1 et MSOUP2 IF (AFFICH) WRITE (*,*) 'Creation des MSOUPO ...' SEGINI, MSOUP1 MSOUP1.IGEOC = MELEME MSOUP1.IPOVAL = MPOVA1 c SEGACT, MCOMP DO 50, IC=1,NC MSOUP1.NOCOMP (IC) = MCOMP.MOTS(IC) MSOUP1.NOHARM(IC)=NIFOUR 50 CONTINUE c SEGDES, MCOMP SEGDES, MSOUP1 SEGINI, MSOUP2=MSOUP1 MSOUP2.IPOVAL = MPOVA2 SEGDES, MSOUP2 * * Creation de MCHPO1 et de MCHPO2 IF (AFFICH) WRITE (*,*) 'Creation des CHPOINT ...' NSOUPO=1 NAT = 2 SEGINI, MCHPO1 MCHPO1.MOCHDE = ' ' MCHPO1.MTYPOI = ' ' MCHPO1.IFOPOI = IFOMOD MCHPO1.IPCHP(1) = MSOUP1 DO 60, J=1,NAT MCHPO1.JATTRI(J)=0 60 CONTINUE SEGDES, MCHPO1 SEGINI, MCHPO2=MCHPO1 MCHPO2.IPCHP(1)=MSOUP2 SEGDES, MCHPO2 * ************************************************ * Creation de la table MODE * ************************************************ * *----- valeur propre (reelle ou complexe) * * Attention : on enregistre f = w/2pi * avec iw = landa donc w=-i landa !!! * IF (AFFICH) WRITE (*,*) 'Construction de la table MODE ...' * CALL CRTABL(MTAB1) CALL ECCTAB(MTAB1,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0, & 'MOT',0,0.0D0,'MODE_COMPLEXE',.TRUE.,0) * CALL ECCTAB(MTAB1,'MOT',0,0.0D0,'NUMERO_MODE',.TRUE.,0, & 'ENTIER',I,0.0D0,' ',.TRUE.,0) CALL CREPO1(0.0D0,0.0D0,0.0D0,IPOIN) CALL ECCTAB(MTAB1,'MOT',0,0.0D0,'POINT_REPERE',.TRUE.,0, & 'POINT',0,0.0D0,' ',.TRUE.,IPOIN) * XVAL=BETA.RE(1,I,1) * CALL ECCTAB(MTAB1,'MOT',0,0.0D0,'FREQUENCE_DEN',.TRUE.,0, * & 'FLOTTANT',0,XVAL,' ',.TRUE.,0) XVAL=(-1*ALFR.RE(1,I,1))/(2*XPI*BETA.RE(1,I,1)) CALL ECCTAB(MTAB1,'MOT',0,0.0D0,'FREQUENCE_IMAGINAIRE',.TRUE.,0 $ ,'FLOTTANT',0,XVAL,' ',.TRUE.,0) XVAL=(ALFI.RE(1,I,1))/(2*XPI*BETA.RE(1,I,1)) CALL ECCTAB(MTAB1,'MOT',0,0.0D0,'FREQUENCE_REELLE',.TRUE.,0, & 'FLOTTANT',0,XVAL,' ',.TRUE.,0) * CALL ECCTAB(MTAB1,'MOT',0,0.0D0,'DEFORMEE_MODALE_REELLE', & .TRUE.,0,'CHPOINT',0,0.0D0,' ',.TRUE.,MCHPO1) CALL ECCTAB(MTAB1,'MOT',0,0.0D0,'DEFORMEE_MODALE_IMAGINAIRE', & .TRUE.,0,'CHPOINT',0,0.0D0,' ',.TRUE.,MCHPO2) * CALL ECCTAB(IPTAB2,'ENTIER',I,0.0D0,' ',.TRUE.,0,'TABLE', & 0,0.0D0,' ',.TRUE.,MTAB1) * IF (MODREL) GOTO 70 * *----- Valeur propre complexe conjuguee * * SEGINI, MTAB2=MTAB1 SEGDES, MTAB2 I = I + 1 IF (AFFICH) WRITE (*,*) 'Mode conjugue, no : ',I CALL ECCTAB(MTAB2,'MOT',0,0.0D0,'NUMERO_MODE',.TRUE.,0, & 'ENTIER',I,0.0D0,' ',.TRUE.,0) CALL ECCTAB(MTAB2,'MOT',0,0.0D0,'FREQUENCE_REELLE',.TRUE.,0, & 'FLOTTANT',0,-1*XVAL,' ',.TRUE.,0) XVAL=-1.D0 CALL MUCHPO(MCHPO2,XVAL,IRET,1) CALL ECCTAB(MTAB2,'MOT',0,0.0D0,'DEFORMEE_MODALE_REELLE', & .TRUE.,0,'CHPOINT',0,0.0D0,' ',.TRUE.,MCHPO1) CALL ECCTAB(MTAB2,'MOT',0,0.0D0,'DEFORMEE_MODALE_IMAGINAIRE', & .TRUE.,0,'CHPOINT',0,0.0D0,' ',.TRUE.,IRET) * CALL ECCTAB(IPTAB2,'ENTIER',I,0.0D0,' ',.TRUE.,0,'TABLE', & 0,0.0D0,' ',.TRUE.,MTAB2) * 70 CONTINUE ENDIF I = I + 1 GOTO 80 20 CONTINUE * IF (AFFICH) WRITE (*,*) 'Nettoyage !!!' SEGSUP, ALFR, ALFI, BETA SEGSUP, MATZ SEGSUP, MCOMP * ******************************************** * Creation de la table BASE_MODALE * ******************************************** * IF (AFFICH) WRITE (*,*) 'Creation de la table BASE_MODALE...' * CALL CRTABL(IPBC) CALL ECCTAB(IPBC,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0, & 'MOT',0,0.0D0,'BASE_MODALE',.TRUE.,0) CALL ECCTAB(IPBC,'MOT',0,0.0D0,'MODES',.TRUE.,0, & 'TABLE',0,0.0D0,' ',.TRUE.,IPTAB2) cbp : on ajoute un indicateur de succes (en plus du message dans vibrac) CONV=ERR.eq.0 CALL ECCTAB(IPBC,'MOT',0,0.0D0,'CONVERGENCE',.TRUE.,0, & 'LOGIQUE ',0,0.0D0,' ',CONV,0) * RETURN END