C QZREST    SOURCE    BP208322  08/12/17    21:15:14     6224           
      SUBROUTINE QZREST(IPBASR, IPBASC, MTAB1)
*
*****************************************************************************
*          RESTITUTION D'UNE BASE DE MODES COMPLEXES A PARTIR               *
*                D'UNE BASE DE MODES COMPLEXES DEFINIE                      *
*                   RELATIVEMENT A UNE BASE REELLE                          *
* _________________________________________________________________________ *
*                                                                           *
*      DATE : le 31 Juillet 1995                                            *
*      AUTEUR : Nicolas BENECH                                              *
* _________________________________________________________________________ *
*                                                                           *
*      MODULE(S) APPELANT(S) : VIBRAC                                       *
*                                                                           *
*      MODULE(S) APPELE(S) : ACCTAB, CRTABL, ECCTAB, EXTRA9, EXTR11         *
* _________________________________________________________________________ *
*                                                                           *
* EN ENTREE :                                                               *
*         - IPBASR : BASE DE MODES REELS PHYSIQUE                           *
*         - IPBASC : BASE DE MODES COMPLEXES RELATIVE A IPBASR              *
* _________________________________________________________________________ *
*                                                                           *
* EN SORTIE :                                                               *
*         - MTAB1 : BASE DE MODES COMPLEXES PHYSIQUE                        *
*****************************************************************************
*
      IMPLICIT INTEGER(I-N)
-INC CCOPTIO
-INC SMCHPOI
-INC SMCOORD
-INC SMELEME
-INC SMLMOTS
-INC SMTABLE
*
      REAL*8 XVALRE
      LOGICAL LOGRE
      CHARACTER*(8) CHARRE
      REAL*8 XVAL1, XVAL2, XVAL4
      INTEGER I, J, K, NNOEUD, NCOMP, NBMODR, NBMODC, SWAP, PT1, PT2
      INTEGER IOBRE
      LOGICAL AFFICH
      CHARACTER* (8) TYPEMODR, TYPEMODC
      CHARACTER*4 MOT1, MOT2
*
      POINTEUR IPBASR2.MTABLE, IPBASR3.MTABLE
      POINTEUR IPBASC2.MTABLE, IPBASC3.MTABLE
      POINTEUR MCHPO5.MCHPOI
*
*----- Ecriture des messages pour verification
      NUMAFF = 23
      AFFICH = ((MOD(IIMPI, NUMAFF).EQ.0) .AND. (IIMPI.NE.0))
*      AFFICH = .TRUE.
*
*----- Fin faute de donnees
      IF (IPBASR*IPBASC .EQ. 0) RETURN
*
*----- Lecture des donnees
      IF (AFFICH) WRITE (*,*) 'Lecture des donnees ...'
      CALL ACCTAB(IPBASR,'MOT',0,0.0D0,'MODES',.TRUE.,0,
     &            'TABLE',IVALRE,XVALRE,CHARRE,LOGRE,IPBASR2)
      CALL ACCTAB(IPBASC,'MOT',0,0.0D0,'MODES',.TRUE.,0,
     &            'TABLE',IVALRE,XVALRE,CHARRE,LOGRE,IPBASC2)
*
* --- Tri des donnees
      IF (AFFICH) WRITE (*,*) 'TEST : ordre des donnees ...'
        CALL ACCTAB(IPBASR2,'ENTIER',1,0.0D0,' ',.TRUE.,0,
     &              'TABLE',IVALRE,XVALRE,CHARRE,LOGRE,IPBASR3)
        CALL ACCTAB(IPBASC2,'ENTIER',1,0.0D0,' ',.TRUE.,0,
     &              'TABLE',IVALRE,XVALRE,CHARRE,LOGRE,IPBASC3)
*
        CALL ACCTAB(IPBASR3,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
     &            'MOT',IVALRE,XVALRE,TYPEMODR,LOGRE,IOBRE)
        CALL ACCTAB(IPBASC3,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
     &            'MOT',IVALRE,XVALRE,TYPEMODC,LOGRE,IOBRE)
      IF (AFFICH) THEN
        WRITE (*,*) 'TYPEMODR = ',TYPEMODR
        WRITE (*,*) 'TYPEMODC = ',TYPEMODC
      ENDIF
*
      IF (((TYPEMODR.EQ.'MODE_COM') .OR. (TYPEMODR.EQ.'MODE_ANN'))
     &     .AND. (TYPEMODC.EQ.'MODE')) THEN
        IF (AFFICH) WRITE (*,*) 'Permutation !'
        SWAP=IPBASR
        IPBASR=IPBASC
        IPBASC=SWAP
        SWAP=IPBASR2
        IPBASR2=IPBASC2
        IPBASC2=SWAP
        TYPEMODR='MODE'
        TYPEMODC='MODE_COM'
      ENDIF
      IF (.NOT. AFFICH) GOTO 1
      IF ((TYPEMODR.EQ.'MODE') .AND. ((TYPEMODC.EQ.'MODE_COM')
     &                              .OR. (TYPEMODR.EQ.'MODE_ANN')))
     &  THEN
        WRITE (*,*) 'OK'
      ELSE
        WRITE (*,*) 'Erreur !'
      ENDIF
  1   CONTINUE
*
*******************************************
*          Donnees fondamentales          *
*******************************************
* --- nombre de modes complexes
      SEGACT, IPBASC2
        NBMODC = IPBASC2.MLOTAB-2
      SEGDES, IPBASC2 
* --- nombre de modes reels
      SEGACT, IPBASR2
        NBMODR = IPBASR2.MLOTAB-2
      SEGDES, IPBASR2
* --- nombre de SOUPO dans les chpoints reels
      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,MCHPO1)
*
      SEGACT, MCHPO1
        NSOUPO=MCHPO1.IPCHP(/1)
      SEGDES, MCHPO1
*
*************************************************
*   Creation de la table MTAB2 BASE_DE_MODES    *
*************************************************
*
      IF (AFFICH) WRITE (*,*) 'Creation de la table BASE_DE_MODES ...'
      CALL CRTABL(MTAB2)
      CALL ECCTAB(MTAB2,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
     &            'MOT',0,0.0D0,'BASE_DE_MODES',.TRUE.,0)
*
      CALL ACCTAB(IPBASR2,'MOT',0,0.0D0,'MAILLAGE',.TRUE.,0,
     &            'MAILLAGE',IVALRE,XVALRE,CHARRE,LOGRE,IPT1)
      CALL ECCTAB(MTAB2,'MOT',0,0.0D0,'MAILLAGE',.TRUE.,0,
     &            'MAILLAGE',0,0.0D0,' ',.TRUE.,IPT1)
*
*
*=========================================*
*     Boucle sur les modes Complexes      *
*=========================================*
*
      DO 20, I=1, NBMODC
      IF (AFFICH) WRITE (*,*) 'Boucle sur les MODES ...', I
*
************************************************
*       Creation de la table MTAB3 du MODE I   *
************************************************
*
        CALL ACCTAB(IPBASC2,'ENTIER',I,0.0D0,' ',.TRUE.,0,
     &            'TABLE   ',IVALRE,XVALRE,CHARRE,LOGRE,IPBASC3)
        SEGINI, MTAB3=IPBASC3
        SEGDES, MTAB3
        CALL ACCTAB(IPBASC3,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
     &                    'MOT',IVALRE,XVALRE,TYPEMODC,LOGRE,IOBRE)
        IF (TYPEMODC .EQ. 'MODE_ANN') GOTO 20
*
***** CALCUL DE LA DEFORMEE MODALE (mchpo3 + i mchpo4) *****
*
* --- Recup de ALFA_R du mode I (=mchpo2)
        CALL ACCTAB(IPBASC3,'MOT',0,0.0D0,'DEFORMEE_MODALE_REELLE',
     &            .TRUE.,0,'CHPOINT',IVALRE,XVALRE,CHARRE,LOGRE,MCHPO2)
* --- Recup de ALFA_I du mode I (=mchpo2)
        CALL ACCTAB(IPBASC3,'MOT',0,0.0D0,'DEFORMEE_MODALE_IMAGINAIRE',
     &            .TRUE.,0,'CHPOINT',IVALRE,XVALRE,CHARRE,LOGRE,MCHPO4)
*
* --- Points supports
        SEGACT, MCHPO2
          MSOUP2 = MCHPO2.IPCHP(1)
        SEGDES, MCHPO2
        SEGACT, MSOUP2
          IPT2 = MSOUP2.IGEOC
        SEGDES, MSOUP2
        SEGACT, IPT2
          NBP2 = IPT2.NUM(/2)
        SEGDES, IPT2
* --- composantes (rem : on ne fait rien si plus de 1 composante....)
        CALL EXTR11(MCHPO2,MLMOT2)
        SEGACT, MLMOT2
          MOT2=MLMOT2.MOTS(1)
        SEGDES, MLMOT2 
*
* --- creation du chpoint Resultat depuis le 1er chpoint mode reel mis à 0
*       partie réelle  MCHPO3
        SEGINI, MCHPO3=MCHPO1
        SEGACT, MCHPO1
        DO 30,  J=1, NSOUPO
      IF (AFFICH) WRITE (*,*) 'création MCHPO3: Boucle sur les SOUPO',J
          MSOUP1 = MCHPO1.IPCHP(J)
          SEGINI, MSOUP3=MSOUP1
            MCHPO3.IPCHP(J) = MSOUP3
          SEGACT, MSOUP1
            MPOVA1 = MSOUP1.IPOVAL
          SEGDES, MSOUP1
          SEGACT, MPOVA1
            N = MPOVA1.VPOCHA(/1)
            NC = MPOVA1.VPOCHA(/2)
          SEGDES, MPOVA1
          SEGINI, MPOVA3
          SEGDES, MPOVA3
            MSOUP3.IPOVAL = MPOVA3
          SEGDES, MSOUP3
*         Maillage et nom de Composantes ne seront pas detruits
 30     CONTINUE
        SEGDES, MCHPO1,MCHPO3
*
*       partie imaginaire  MCHPO5
        SEGINI, MCHPO5=MCHPO1
        SEGACT, MCHPO1
        DO 31,  J=1, NSOUPO
      IF (AFFICH) WRITE (*,*) 'création MCHPO5: Boucle sur les SOUPO',J
          MSOUP1 = MCHPO1.IPCHP(J)
          SEGINI, MSOUP5=MSOUP1
            MCHPO5.IPCHP(J) = MSOUP5
          SEGACT, MSOUP1
            MPOVA1 = MSOUP1.IPOVAL
          SEGDES, MSOUP1
          SEGACT, MPOVA1
            N = MPOVA1.VPOCHA(/1)
            NC = MPOVA1.VPOCHA(/2)
          SEGDES, MPOVA1
          SEGINI, MPOVA5
          SEGDES, MPOVA5
            MSOUP5.IPOVAL = MPOVA5
          SEGDES, MSOUP5
*         Maillage et nom de Composantes ne seront pas detruits
 31     CONTINUE
        SEGDES, MCHPO1,MCHPO5
*
*
******************************************
*     Boucle sur les noeuds supports     *
******************************************
*
         DO 50, K=1, NBP2
         
        IF (AFFICH) WRITE (*,*) '---  Noeud support ',K,'  ---'
            SEGACT, IPT2
              PT2 = IPT2.NUM(1,K)
            SEGDES, IPT2
* ---       Contribution a mchpo3
            CALL EXTRA9(MCHPO2,PT2,MOT2,KERRE,XVAL2)
* ---       Contribution a mchpo5
            CALL EXTRA9(MCHPO4,PT2,MOT2,KERR2,XVAL4)
        IF (AFFICH) WRITE (*,*) '   alfa_R et alfa_I = ',XVAL2,XVAL4

* --- on recherche le chpoint reel correspondant
            L=1
 60           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,PT1)
            IF (PT1 .NE. PT2) THEN
              L=L+1
              IF (L .LE. NBMODR) GOTO 60
            ELSE
              CALL ACCTAB(IPBASR3,'MOT',0,0.0D0,'DEFORMEE_MODALE',
     &                    .TRUE.,0,'CHPOINT',IVALRE,XVALRE,CHARRE,LOGRE,
     &                    MCHPO1)
      IF (AFFICH) WRITE (*,*) '   Prise en compte du MCHPO1', L,MCHPO1
*
* ---         Sommes...
              MSOMM3=0
              XVAL1=1.d0
              IF (AFFICH) WRITE (*,*) 'Somme ...',MSOMM3,XVAL1,XVAL2
* ---         ... pour mchpo3
              call ADCHPO(MCHPO3,MCHPO1,MSOMM3,XVAL1,XVAL2)
              call DTCHPO(MCHPO3)
              MCHPO3=MSOMM3
* ---         ... pour mchpo5
              call ADCHPO(MCHPO5,MCHPO1,MSOMM5,XVAL1,XVAL4)
              call DTCHPO(MCHPO5)
              MCHPO5=MSOMM5
*
            ENDIF

 50      CONTINUE
*********************************************
*      Fin de boucle sur les noeuds support *
*********************************************
*
      IF (AFFICH) WRITE (*,*) 'Enregistrement du CHPOINT ...'
* --- enregistrement du chpoint
        CALL ECCTAB(MTAB3,'MOT',0,0.0D0,'DEFORMEE_MODALE_REELLE',
     &            .TRUE.,0,'CHPOINT',0,0.0D0,' ',.TRUE.,MCHPO3)
* --- enregistrement du chpoint
        CALL ECCTAB(MTAB3,'MOT',0,0.0D0,'DEFORMEE_MODALE_IMAGINAIRE',
     &            .TRUE.,0,'CHPOINT',0,0.0D0,' ',.TRUE.,MCHPO5)
* --- enregistrement du mode
        CALL ECCTAB(MTAB2,'ENTIER',I,0.0D0,' ',
     &            .TRUE.,0,'TABLE   ',0,0.0D0,' ',.TRUE.,MTAB3)

 20   CONTINUE
******************************************
*        Fin boucle sur les modes        *
******************************************
*
*
******************************************
*   Creation de la table BASE_MODALE     *
******************************************
*
      CALL CRTABL(MTAB1)
      CALL ECCTAB(MTAB1,'MOT',0,0.0D0,'SOUSTYPE',.TRUE.,0,
     &             'MOT',0,0.0D0,'BASE_MODALE',.TRUE.,0)
      CALL ECCTAB(MTAB1,'MOT',I,0.0D0,'MODES',
     &            .TRUE.,0,'TABLE   ',0,0.0D0,' ',.TRUE.,MTAB2)
*
* --- fin
*
      RETURN
      END
*