C RECOBAL SOURCE BP208322 13/07/25 21:15:06 7804 C RECOMB SOURCE GORC 95/08/03 21:15:14 1766 SUBROUTINE RECOBAL (IPBASR, MCHPO1, MCHPO2, MCHPO4) IMPLICIT INTEGER(I-N) IMPLICIT REAL*8 (A-H,O-Z) * ***************************************************************************** * RECOMBINAISON MODALE DE LA REPONSE BALOURD (CHPOINT) A PARTIR * * DES DEFORMEES MODALES DE LA BASE REELLE * * _________________________________________________________________________ * * * * CREATION : le 14 Mars 1996 * * DERNIERE MODIF. : 19/11/96 * * AUTEUR : Jerome CHARPENTIER * * MODIF : BP 07/2013, on ne met pas à 0 lorsque la valeur est <1.E-10 !* * _________________________________________________________________________ * * * * MODULE(S) APPELANT(S) : VIBRAC * * * * MODULE(S) APPELE(S) : ACCTAB, CRTABL, ECCTAB, EXTRA9, EXTR11 * * _________________________________________________________________________ * * * * EN ENTREE : * * - IPBASR : BASE DES MODES REELS PHYSIQUES * * - MCHPO1 : CHPOINT DE LA REPONSE EN DEPLACEMENT MODAUX * * DIMENSION 2N -> LES N PREMIERES COMPOSANTES * * CORRESPONDENT AUX POINTS REPERES DE LA BASE * * PHYSIQUE (REELLE) * * _________________________________________________________________________ * * * * EN SORTIE : * * - MCHPO2 : CHPOINT DE LA REPONSE EN DEPLACEMENT DANS LA BASE * * PHYSIQUE (PARTIE REELLE) * * - MCHPO4 : CHPOINT DE LA REPONSE EN DEPLACEMENT DANS LA BASE * * PHYSIQUE (PARTIE IMAGINAIRE) * ***************************************************************************** * -INC CCOPTIO -INC SMCHPOI -INC SMCOORD -INC SMELEME -INC SMLMOTS -INC SMTABLE * REAL*8 XVAL1S, XVAL1C, XVAL3, VAL21, VAL41 INTEGER I, J, K, NBNOEU, NBCOMP, NBMODR, PT1S, PT1C, PT3 LOGICAL AFFICH CHARACTER*4 MOT1, MOT3 REAL*8 XVALRE LOGICAL LOGRE CHARACTER*(8) CHARRE * POINTEUR IPBASR2.MTABLE, IPBASR3.MTABLE * *---- Affichage des messages pour verification AFFICH = .FALSE. * *---- Lecture de la base reelle IPBASR2 = TBasR.MODES IF (AFFICH) WRITE (*,*) 'Lecture des donnees ...' CALL ACCTAB(IPBASR,'MOT',0,0.0D0,'MODES',.TRUE.,0, & 'TABLE',IVALRE,XVALRE,CHARRE,LOGRE,IPBASR2) * ******************************************* *---- Initialisation des donnees ******************************************* * * --- Nombre de modes reels = NBMODR SEGACT, IPBASR2 NBMODR = IPBASR2.MLOTAB-2 SEGDES, IPBASR2 * * --- Nbre de SOUPO dans les deformee modale de la base reelle CALL ACCTAB(IPBASR2,'ENTIER',1,0.0D0,' ',.TRUE.,0, & 'TABLE ',IVALRE,XVALRE,CHARRE,LOGRE,IPBASR3) CALL ACCTAB(IPBASR3,'MOT',0,0.0D0,'DEFORMEE_MODALE',.TRUE., & 0,'CHPOINT',IVALRE,XVALRE,CHARRE,LOGRE,MCHPO3) SEGACT, MCHPO3 NSOUPO = MCHPO3.IPCHP(/1) SEGDES, MCHPO3 IF (AFFICH) WRITE (*,*) 'NSOUPO=', NSOUPO * * --- Nbre de pts dans la reponse modale SEGACT, MCHPO1 MSOUP1 = MCHPO1.IPCHP(1) SEGDES, MCHPO1 SEGACT, MSOUP1 IPT1 = MSOUP1.IGEOC SEGDES, MSOUP1 * SEGACT, IPT1 NBP1 = IPT1.NUM(/2) SEGDES, IPT1 IF (AFFICH) WRITE (6,*) 'NBMODR=', NBMODR * IF ((2*NBMODR) .NE. NBP1) RETURN SEGINI, MCHPO2=MCHPO3 SEGDES, MCHPO2 SEGINI, MCHPO4=MCHPO3 SEGDES, MCHPO4 * ********************************************************* *---- Boucle sur les SOUPO des deformees de la BasR ********************************************************* DO 10, J=1, NSOUPO IF (AFFICH) WRITE (*,*) 'Boucle sur Soupos ...', J * CALL ACCTAB(IPBASR2,'ENTIER',1,0.0D0,' ',.TRUE.,0, & 'TABLE ',IVALRE,XVALRE,CHARRE,LOGRE,IPBASR3) CALL ACCTAB(IPBASR3,'MOT',0,0.0D0,'DEFORMEE_MODALE',.TRUE., & 0,'CHPOINT',IVALRE,XVALRE,CHARRE,LOGRE,MCHPO3) * *-------- Creation des SOUPOs resultat pour les rep. reelle & imag. SEGACT, MCHPO3 MSOUP3 = MCHPO3.IPCHP(J) SEGDES, MCHPO3 SEGINI, MSOUP2=MSOUP3 SEGDES, MSOUP2 SEGINI, MSOUP4=MSOUP3 SEGDES, MSOUP4 * * --- Nbre de Noeuds et de composantes dans le SOUPO SEGACT, MSOUP3 MPOVA3 = MSOUP3.IPOVAL IPT3 = MSOUP3.IGEOC SEGDES, MSOUP3 SEGACT, MPOVA3 NBNOEU = MPOVA3.VPOCHA(/1) NBCOMP = MPOVA3.VPOCHA(/2) SEGDES, MPOVA3 IF (AFFICH) WRITE (*,*) 'NBNOEU=', NBNOEU IF (AFFICH) WRITE (*,*) 'NBCOMP=', NBCOMP * * --- Noms des composantes du SOUPO SEGACT, MSOUP3 JGN=4 JGM=NBCOMP SEGINI, MLMOT3 DO 60, K=1, NBCOMP MLMOT3.MOTS(K)=MSOUP3.NOCOMP(K) 60 CONTINUE SEGDES, MLMOT3 SEGDES, MSOUP3 * * --- Initialisation des MPOVAs pour des reponses SEGACT, MPOVA3 SEGINI, MPOVA2=MPOVA3 SEGDES, MPOVA2 SEGINI, MPOVA4=MPOVA3 SEGDES, MPOVA4 SEGDES, MPOVA3 DO 50, ICOMP = 1, NBCOMP SEGACT, MLMOT3 MOT3 = MLMOT3.MOTS(ICOMP) SEGDES, MLMOT3 DO 50, INOEUD = 1, NBNOEU SEGACT, MPOVA2*MOD MPOVA2.VPOCHA(INOEUD,ICOMP)=0 SEGDES, MPOVA2 SEGACT, MPOVA4*MOD MPOVA4.VPOCHA(INOEUD,ICOMP)=0 SEGDES, MPOVA4 50 CONTINUE * *---- Boucle sur les depl. modaux de la reponse Qi ********************************************************* * DO 20, I=1, NBMODR IF (AFFICH) WRITE (*,*) 'Boucle sur les Qi ...', I * * --- Recup. des valeurs de la reponse modale Qi SEGACT, IPT1 PT1S = IPT1.NUM(1,I+NBMODR) PT1C = IPT1.NUM(1,I) SEGDES, IPT1 CALL EXTR11(MCHPO1,MLMOT1) SEGACT, MLMOT1 MOT1 = MLMOT1.MOTS(1) SEGDES, MLMOT1 CALL EXTRA9(MCHPO1,PT1S,MOT1,KERRE,XVAL1S) CALL EXTRA9(MCHPO1,PT1C,MOT1,KERRE,XVAL1C) IF (AFFICH) WRITE (*,*) 'COMP=', MOT1 IF (AFFICH) WRITE (*,*) 'PT1S=', PT1S, XVAL1S IF (AFFICH) WRITE (*,*) 'PT1C=', PT1C, XVAL1C * *-------- Recherche du mode reel correspondant a Qi L=1 30 CALL ACCTAB(IPBASR2,'ENTIER',L,0.0D0,' ',.TRUE., & 0,'TABLE ',IVALRE,XVALRE,CHARRE,LOGRE,IPBASR3) CALL ACCTAB(IPBASR3,'MOT',0,0.0D0,'POINT_REPERE',.TRUE., & 0,'POINT',IVALRE,XVALRE,CHARRE,LOGRE,PT3) IF ((PT1S .NE. PT3) .AND. (PT1C .NE. PT3)) THEN L=L+1 IF (L .LE. NBMODR) GOTO 30 ELSE * *-------- Calcul de la reponse reelle IF (AFFICH) WRITE (*,*) 'Prise en compte du MODE ...', L, PT3 CALL ACCTAB(IPBASR3,'MOT',0,0.0D0,'DEFORMEE_MODALE', & .TRUE.,0,'CHPOINT',IVALRE,XVALRE,CHARRE,LOGRE,MCHPO3) * IF (AFFICH) WRITE (*,*) 'Deformee modale=', MCHPO3 * DO 40, ICOMP = 1, NBCOMP SEGACT, MLMOT3 MOT3 = MLMOT3.MOTS(ICOMP) SEGDES, MLMOT3 IF (AFFICH) WRITE (*,*) 'COMP=', MOT3 DO 40, INOEUD = 1, NBNOEU SEGACT, IPT3 PT3 = IPT3.NUM(1,INOEUD) SEGDES, IPT3 IF (AFFICH) WRITE (*,*) 'P3=', PT3 CALL EXTRA9(MCHPO3,PT3,MOT3,KERRE,XVAL3) IF (AFFICH) WRITE (*,*) 'XVAL3=', XVAL3 SEGACT, MPOVA2*MOD VAL21=MPOVA2.VPOCHA(INOEUD,ICOMP) IF (AFFICH) WRITE (*,*) 'VPOCH2=', VAL21 MPOVA2.VPOCHA(INOEUD,ICOMP)= & MPOVA2.VPOCHA(INOEUD,ICOMP)+XVAL3*XVAL1S VAL21=MPOVA2.VPOCHA(INOEUD,ICOMP) IF (AFFICH) WRITE (*,*) 'VPOCH2=', VAL21 SEGDES, MPOVA2 SEGACT, MPOVA4*MOD MPOVA4.VPOCHA(INOEUD,ICOMP)= & MPOVA4.VPOCHA(INOEUD,ICOMP)+XVAL3*XVAL1C VAL41=MPOVA4.VPOCHA(INOEUD,ICOMP) IF (AFFICH) WRITE (*,*) 'VPOCH4=', VAL41 SEGDES, MPOVA4 40 CONTINUE ENDIF * 20 CONTINUE ********************************************************* *---- Fin Boucle sur les depl. modaux de la reponse Qi * c bp GOTO 71 * --- Mise a zero des valeurs inferieures a 1e-10 DO 70, ICOMP = 1, NBCOMP SEGACT, MLMOT3 MOT3 = MLMOT3.MOTS(ICOMP) SEGDES, MLMOT3 DO 70, INOEUD = 1, NBNOEU SEGACT, IPT3 PT3 = IPT3.NUM(1,INOEUD) SEGDES, IPT3 CALL EXTRA9(MCHPO3,PT3,MOT3,KERRE,XVAL3) SEGACT, MPOVA2*MOD VAL21=ABS(MPOVA2.VPOCHA(INOEUD,ICOMP)) IF (VAL21 .LE. 1E-10) MPOVA2.VPOCHA(INOEUD,ICOMP)=0 SEGDES, MPOVA2 SEGACT, MPOVA4*MOD VAL41=ABS(MPOVA4.VPOCHA(INOEUD,ICOMP)) IF (VAL41 .LE. 1E-10) MPOVA4.VPOCHA(INOEUD,ICOMP)=0 SEGDES, MPOVA4 70 CONTINUE 71 CONTINUE * *------ enregistrement du SOUPO SEGACT, MSOUP2*MOD MSOUP2.IPOVAL=MPOVA2 SEGDES, MSOUP2 SEGACT, MSOUP4*MOD MSOUP4.IPOVAL=MPOVA4 SEGDES, MSOUP4 SEGACT, MCHPO2*MOD MCHPO2.IPCHP(J)=MSOUP2 SEGDES, MCHPO2 SEGACT, MCHPO4*MOD MCHPO4.IPCHP(J)=MSOUP4 SEGDES, MCHPO4 * 10 CONTINUE *---- Fin Boucle sur les SOUPO des deformees de la BasR ********************************************************* * RETURN END *