C AMOR      SOURCE    CB215821  19/07/31    21:15:25     10277          
      SUBROUTINE AMOR
C
C***********************************************************************
C                                                                      *
C  Premiere option :                                                   *
C                                                                      *
C      FABRICATION DE LA MATRICE D'AMORTISSEMENT MODAL                 *
C      SYNTAXE : AMO1= AMOR BASE PROG ;                                *
C        AMO1   MATRICE D'AMORTISSEMENT                                *
C        BASE   OBJET DE TYPE BASE MODALE                              *
C        PROG   OBJET DE TYPE MLREEL LISTE DES                         *
C        COEFFICIENTS D'AMORTISSEMENT REDUITS (%)                      *
C        CREATION    : 26/11/86                                        *
C        PROGRAMMEUR : GUILBAUD                                        *
C                                                                      *
C______________________________________________________________________*
C                                                                      *
C  Deuxieme option : calcule la matrice d'amortissement visqueux       *
C                    associee a la frontiere d'un maillage             *
C                                                                      *
C  Syntaxe :                                                           *
C  --------                                                            *
C                                                                      *
C    RIG1 = AMOR MODL1 MAT1 GEO1 ;                                     *
C                                                                      *
C  RIG1 : matrice d'amortissement construite (TYPE rigidite)           *
C  MODL1: objet MMODEL, modele du sol ou du fluide a modeliser         *
C  MAT1 : objet MCHAML, caracteristiques materiau                      *
C  GEO1 : objet MELEME, maillage de la frontiere                       *
C                                                                      *
C  date de creation : 26/02/98                                         *
C  "programmeur" : Olivier ROCHET                                      *
C                                                                      *
C______________________________________________________________________*
C                                                                      *
C  Troisieme option : calcule la matrice d'amortissement               *
C                    d'un materiau viscoelastique                      *
C                                                                      *
C  Syntaxe :                                                           *
C  --------                                                            *
C                                                                      *
C    RIG1 (RIG2) = AMOR MODL1 MAT1 ('COROTATIF') ;                     *
C                                                                      *
C  RIG1 : matrice d'amortissement construite (TYPE rigidite)           *
C  MODL1: objet MMODEL, modele du sol ou du fluide a modeliser         *
C  MAT1 : objet MCHAML, caracteristiques materiau                      *
C  L'option COROTATIF permet de calculer la matrice de rigidite        *
C  antisymetrique d'un arbre tournant (elements de poutre uniquement)  *
C                                                                      *
C  date de creation : 07/07/03                                         *
C  "programmeur" : Didier COMBESCURE                                   *
C                                                                      *
C***********************************************************************
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)


-INC PPARAM
-INC CCOPTIO
*
      PARAMETER (NPARAM = 1)

      LOGICAL BASMUL
      CHARACTER*8 CTYP
      CHARACTER*4 LPARAM(NPARAM)
*
      DATA LPARAM / 'CORO' /
*
      iretou = 0
*
      CALL LIROBJ('LISTREEL',IPRO,0,iretou)
      IF (IERR.NE.0) RETURN
*
* -----
* Cas 1 - Amortissement modal
* -----
      IF (iretou.EQ.1) THEN
*
        ICAS = 1
        IPRIG = 0
*
        IBASE = 0
        ITBAS = 0
        BASMUL = .FALSE.
*
        CALL QUETYP(CTYP,1,iretou)
        IF (IERR.NE.0) RETURN
        IF (CTYP(1:8).EQ.'TABLE   ') THEN
          CALL LIRTAB('BASE_MODALE',ITBAS,0,iretou)
          IF (IERR.NE.0) RETURN
          IF (iretou.EQ.0) THEN
            CALL LIRTAB('ENSEMBLE_DE_BASES',ITBAS,1,iretou)
            IF (IERR.NE.0) RETURN
            BASMUL = .TRUE.
          ENDIF
        ELSE
          CALL LIROBJ('BASEMODA',IBASE,1,iretou)
          IF (IERR.NE.0) RETURN
        ENDIF
*
        CALL AMORMO(IPRO,IBASE,ITBAS,BASMUL, IPRIG)
        IF (IERR.NE.0 .OR. IPRIG.LE.0) RETURN
*
        CALL ECROBJ('RIGIDITE',IPRIG)
*
* ----------
* Cas 2 et 3 - Frontieres absorbantes et amortissement visqueux
* ----------
      ELSE
*
        IPMODL = 0
        IPCHE1 = 0
        IPMAIL = 0
        IPRIG  = 0
        IPRIG2 = 0
C
C  lecture du modele
C
        CALL LIROBJ('MMODEL  ',IPMODL,1,iretou)
        CALL ACTOBJ('MMODEL  ',IPMODL,1)
        IF (IERR.NE.0) RETURN
C
C  lecture du mchaml de caracteristiques materiau
C
        CALL LIROBJ('MCHAML  ',IPIN,1,iretou)
        CALL ACTOBJ('MCHAML  ',IPIN,1)
        IF (IERR.NE.0) RETURN
        CALL REDUAF(IPIN,IPMODL,IPCHE1,0,IR,KER)
        IF(IR   .NE. 1) CALL ERREUR(KER)
        IF(IERR .NE. 0) RETURN
C
C  lecture du maillage de la frontiere
C
        CALL LIROBJ('MAILLAGE',IPMAIL,0,iretou)
        IF (IERR.NE.0) RETURN
*
        IF (iretou.NE.0) THEN
          ICAS = 2
        ELSE
          ICAS = 3
          CALL LIRMOT(LPARAM,NPARAM,iretou,0)
          IF (IERR.NE.0) RETURN
          IF (iretou.EQ.1) ICAS = 4
        ENDIF
C
        IF (ICAS.EQ.2) THEN
C
          CALL FRVISQ(IPMODL,IPMAIL,IPCHE1, IPRIG)
          IF (IERR.NE.0 .OR. IPRIG.LE.0) RETURN
C
        ELSE IF (ICAS.EQ.3) THEN
C
          CALL AMOR1(IPMODL,IPCHE1,1, IPRIG)
          IF (IERR.NE.0 .OR. IPRIG.LE.0) RETURN
C
        ELSE IF (ICAS.EQ.4) THEN
C
          CALL AMOR1(IPMODL,IPCHE1,2, IPRIG)
          IF (IERR.NE.0 .OR. IPRIG.LE.0) RETURN
C
          CALL AMOR1(IPMODL,IPCHE1,1, IPRIG2)
          IF (IERR.NE.0 .OR. IPRIG2.LE.0) RETURN
        ENDIF
C
        CALL ECROBJ('RIGIDITE',IPRIG)
        IF (ICAS.EQ.4) CALL ECROBJ('RIGIDITE',IPRIG2)
C
      ENDIF
      END