C VIBRAT    SOURCE    CHAT      09/10/09    21:25:51     6519           
      SUBROUTINE VIBRAT                                                         
************************************************************************        
*                                                                               
*                             V I B R A T                                       
*                             -----------                                       
*                                                                               
*            SOUS-PROGRAMME ASSOCIE A L'OPERATEUR "VIBRATION"                   
*                                                                               
* FONCTION:                                                                     
* ---------                                                                     
*                                                                               
*     CALCUL DE MODES PROPRES.                                                  
*                                                                               
* PHRASE D'APPEL (EN GIBIANE):                                                  
* ----------------------------                                                  
*                                                                               
*     ..... = VIBRATION | PROCHE .....     | ;                                  
*                       | INTERVALLE ..... |                                    
*                       | SIMULTANE .....  |                                    
*                                                                               
*     VOIR LES DETAILS DANS LES SOUS-PROGRAMMES ASSOCIES AUX OPTIONS            
*     "PROCHE", "INTERVALLE", ETC...                                            
*                                                                               
* SOUS-PROGRAMMES APPELES:                                                      
* ------------------------                                                      
*                                                                               
*     INTVAL, LIRMOT, PROCHE, SIMULT.                                           
*                                                                               
* AUTEUR, DATE DE CREATION:                                                     
* -------------------------                                                     
*                                                                               
*     PASCAL MANIGOT     13 NOVEMBRE 1984                                       
*                                                                               
* LANGAGE:                                                                      
* --------                                                                      
*                                                                               
*     FORTRAN77 + EXTENSION: CARACTERES MIS DANS DES ENTIERS                    
*                                                                               
************************************************************************        
*                                                                               
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)                                                 
-INC CCOPTIO
-INC SMSOLUT
-INC SMCHPOI
-INC SMRIGID
-INC SMTABLE
*                                                                               
      COMMON/CITINV/ NBITER,IACCEL,NUMAC,IPX2,IPX0,IPX1,IPBX1,                  
     C IBBX1,IBBX2,ITPRO,DIFREL                                                 
*                                                                               
      PARAMETER (NBRMOT = 8)                                                    
*                                                                               
      CHARACTER*4 LISMOT(NBRMOT) 
      CHARACTER*8 letyp,charre
                                               
*                                                                               
      LOGICAL LOG1, LIMAGE, LMULT,boolin                                                             
*                                                                               
      DATA LISMOT/'PROC','INTE','SIMU','IMPR','BASS','HAUT',
     1            'TBAS','MULT'/             
*                                                                               
      IBASS=0                                                                   
      IHAUT=0                                                                   
      NOPT=0                                                                    
      LOG1 = .FALSE.
      LMULT = .FALSE.
      LIMAGE=  .FALSE.                                                           
      NIMP=IIMPI                                                                
      ICODE = 0                                                                 
      NBMOT = NBRMOT                                                            
      DO 10 I=1,5                                                               
      CALL LIRMOT (LISMOT,NBMOT,NUMLIS,ICODE)                                   
      IF (IERR .NE. 0) RETURN                                                   
      IF (NUMLIS.EQ.0) GOTO 10
      IF(NUMLIS.LE.3) THEN                                                  
        IF (NUMLIS.EQ.1) THEN
           CALL LIROBJ ('LISTREEL',IPFREQ,1,IRETOU)
           IF(IERR.NE.0) RETURN
           IPNMOD = 0                                                                 
           CALL LIROBJ ( 'LISTENTI', IPNMOD, 0, IRETOU )                              
           IF (IERR .NE. 0) RETURN
        ENDIF
        IF(NUMLIS.EQ.2) THEN
           CALL LIRREE(XINT1,1,IRETOU)
           IF(IERR.NE.0) RETURN      
           CALL LIRREE(XINT2,1,IRETOU)
           IF(IERR.NE.0) RETURN      
        ENDIF 
        IF(NUMLIS.EQ.3) THEN
           CALL LIRREE(XINT1,1,IRETOU)
           IF(IERR.NE.0) RETURN    
           CALL LIRENT (IBASS,1,IRETOU)
           IF(IERR.NE.0) RETURN    
        ENDIF                                                
        NOPT=NUMLIS                                                               
        GOTO 10                                                                   
      ENDIF                                                                     
      IF (NUMLIS.EQ.4) THEN                                                     
***     IIMPI=2
        CALL GINT2                                                              
      ENDIF                                                                     
      IF (NUMLIS.EQ.5)  CALL LIRENT (IBASS,1,IRETOU)
      IF(IERR.NE.0) RETURN                                              
      IF (NUMLIS.EQ.6)  CALL LIRENT(IHAUT,1,IRETOU)                                              
      IF(IERR.NE.0) RETURN 
      IF (NUMLIS.EQ.7) LOG1 = .TRUE.  
      IF (NUMLIS.EQ.8) LMULT = .TRUE.                                          
10    CONTINUE                                                                  
      CALL LIROBJ('RIGIDITE',IPRIG1,1,IRETOU) 
      IF(IERR.NE.0) RETURN 
      CALL LIROBJ ('RIGIDITE',IPRIG2,1,IRETOU)
      IF(IERR.NE.0) RETURN  
      CALL WHICH1 (IPRIG1,IPRIG2,IPRIGI,IPMASS) 
      iprig1=iprigi 
      iprig2=ipmass                      
      CALL LIRLOG(LIMAGE,0,IRETOU)  
*  dualisation des mult de Lagrange
      mrigid=iprig1
      segini,ri1=mrigid
      segdes mrigid
      mrigid=ri1
      imgeo2=0
      call dbblx(mrigid,lagdua)
      imlag=lagdua
      iprig1=mrigid
*                                                                               
      IF (NOPT .EQ. 1) THEN                                                     
         ITPRO=1                                                                
         CALL PROCHE (IPMASS,IPSOLU,IPFREQ,IPRIG1,IPRIG2,LIMAGE,
     &        IPNMOD,MBASC,INSYM)
         IF(IERR.NE.0) RETURN
      ELSE IF (NOPT .EQ. 2) THEN                                                
         ITPRO=0                                                               
         CALL INTVAL (IPMASS,IPSOLU,XINT1,XINT2,IBASS,IHAUT,
     $          LIMAGE,IPRIG1,IPRIG2,LMULT)
         INSYM = 0                                            
         IF(IERR.NE.0) RETURN
      ELSE IF (NOPT .EQ. 3) THEN                                                
         ITPRO=0                                                                
         CALL SIMULT (IPMASS,IPSOLU,IPRIG1,IPRIG2,LIMAGE,XINT1,IBASS)
         IF(IERR.NE.0) RETURN
         INSYM = 0
      ELSE                                                                      
         CALL ERREUR (533)                                                      
         RETURN
      ENDIF 
*  dedualisation de la solution
      IF(insym.eq.0) then
         msolut=ipsolu
         segact msolut*mod
         do 210 ilx=1,msolit(/1)
          if (msolit(ilx).eq.2) then
          msolen=msolis(ilx)
          segact msolen*mod
          do 200 iso=1,isolen(/1)
           mchpoi=isolen(iso)
           segact mchpoi*mod
           if (lagdua.ne.0) call dbbcf(mchpoi,lagdua)
           isolen(iso)=mchpoi
 200      continue
          endif
 210     continue
      ELSE
       if (lagdua.ne.0)  then
       mtable=mbasc
       segact mtable
       call acctab(mbasc,'MOT     ',iva,xvalin,'MODES',boolin,iobin,
     $            'TABLE  ',ivalre,xvalre,charre,boolin,mtab1)
       do 250 i=1,10000
        letyp=' '
        call acctab (mtab1,'ENTIER  ',i,xva,charre,boolin,iobin,
     $         letyp,ivalre,xvalre,charre,boolin,mtab2)
        if(letyp.ne.'TABLE   ') go to 251
         letyp=' '
         call acctab(mtab2,'MOT',iva,xva,'DEFORMEE_MODALE_REELLE',
     $ boolin,iobin,letyp,ivalre,xvalre,charre,boolin,iobre) 
       if(letyp.eq.'CHPOINT') then
          mchpoi=iobre                  
          segact mchpoi*mod
          call dbbcf(mchpoi,lagdua)
          call ecctab(mtab2,'MOT',iva,xva,'DEFORMEE_MODALE_REELLE', 
     $    boolin,iobin,letyp,ivalre,xvalre,charre,boolin,mchpoi)        
       else
        call erreur(5)
        return
       endif
        letyp=' '
        call acctab(mtab2,'MOT',iva,xva,'DEFORMEE_MODALE_IMAGINAIRE', 
     $ boolin,iobin,letyp,ivalre,xvalre,charre,boolin,iobre) 
       if(letyp.eq.' ')go to 250
          mchpoi=iobre                  
          segact mchpoi*mod
          call dbbcf(mchpoi,lagdua)
          call ecctab(mtab2,'MOT',ivalin,xva,'DEFORMEE_MODALE_IMAG', 
     $    boolin,iobin,letyp,ivalre,xvalre,charre,boolin,mchpoi)
  250 continue
      endif 
  251 continue    
      ENDIF

                                                                     
      IF (INSYM .EQ. 0) THEN  
                                                                             
       IF (LOG1) THEN 
          CALL CRTBAS (IPSOLU,IPMASS)                                            
          CALL DESOLU (IPSOLU)                                                   
       ELSE                                                                      
          CALL ECROBJ ('SOLUTION',IPSOLU)                                        
       ENDIF
      ELSE
        CALL LIROBJ('CHPOINT', IPOINT, 0, IRETOU)
        CALL ECROBJ('TABLE', MBASC) 
      END IF                                                                         
       IIMPI=NIMP                                                                
       CALL GINT2   
                                                                     
      END