C AMORMO    SOURCE    PV090527  26/04/30    21:15:05     12529          

      SUBROUTINE AMORMO (IPROG,IBASE,ITABL,BASMUL, IPRIG)

C***********************************************************************
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***********************************************************************

      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)


-INC PPARAM
-INC CCOPTIO

-INC SMLREEL
-INC SMRIGID
-INC SMBASEM
-INC SMSOLUT
*
      LOGICAL BASMUL

      LOGICAL L0,L1
      CHARACTER*8 TYPRET,CHARRE

      MLREEL = IPROG
      SEGACT,MLREEL
      LON = PROG(/1)

      IP = 0

      IF (IBASE.LE.0) THEN
c* equivalent a IF (ITABL.GT.0) THEN
        IF (BASMUL) THEN
          ITBAM = ITABL
          IB = 0
 10       CONTINUE
          IB = IB + 1
          TYPRET = ' '
          CALL ACCTAB(ITBAM,'ENTIER',IB,X0,' ',L0,IP0,
     &                      TYPRET,I1,X1,CHARRE,L1,IBAS)
          IF (IBAS.NE.0 .AND. TYPRET.EQ.'TABLE   ') GOTO 10
          NBASE = IB - 1
          DO NBAS = 1, NBASE
            CALL ACCTAB(ITBAM,'ENTIER',NBAS,X0,' ',L0,IP0,
     &                        'TABLE',I1,X1,CHARRE,L1,ITBAS)
            CALL ACCTAB(ITBAS,'MOT',I0,X0,'MODES',L0,IP0,
     &                        'TABLE',I1,X1,CHARRE,L1,NTBAS)
            IB = 0
 14         CONTINUE
            IB = IB + 1
            TYPRET = ' '
            CALL ACCTAB(NTBAS,'ENTIER',IB,X0,' ',L0,IP0,
     &                        TYPRET,I1,X1,CHARRE,L1,ITMOD)
            IF (ITMOD.NE.0 .AND. TYPRET.EQ.'TABLE   ') GOTO 14
            IP = IP + IB - 1
          ENDDO
        ELSE
          ITBAS = ITABL
          NBASE = 1
          CALL ACCTAB(ITBAS,'MOT',I0,X0,'MODES',L0,IP0,
     &                      'TABLE',I1,X1,' ',L1,NTBAS)
          IB = 0
 16       CONTINUE
          IB = IB + 1
          TYPRET = ' '
          CALL ACCTAB(NTBAS,'ENTIER',IB,X0,' ',L0,IP0,
     &                      TYPRET,I1,X1,CHARRE,L1,ITMOD)
          IF (ITMOD.NE.0 .AND. TYPRET.EQ.'TABLE   ') GOTO 16
          IP = IP + IB - 1
        ENDIF
      ELSE
        MBASEM = IBASE
        SEGACT,MBASEM
        NBASE = LISBAS(/1)
        DO 20 NBAS = 1,NBASE
          MSOBAS = LISBAS(NBAS)
          SEGACT,MSOBAS
          MSOLUT = IBSTRM(2)
          SEGACT,MSOLUT
          MSOLEN = MSOLIS(4)
          SEGACT,MSOLEN
          IP = IP + ISOLEN(/1)
          SEGDES,MSOLEN,MSOLUT,MSOBAS
 20     CONTINUE
      ENDIF

*   le nb de modes de la base n'est pas egal au nb d'amortissements
      IF (LON.NE.IP) THEN
        CALL ERREUR(209)
        GOTO 999
      ENDIF

      KRIGI = 0
      IRIG = 3
      IP = 0
      DO 100 NBAS = 1,NBASE
        IF (IBASE.EQ.0) THEN
          IF ( BASMUL ) THEN
            CALL ACCTAB(ITBAM,'ENTIER',NBAS,X0,' ',L0,IP0,
     &                        'TABLE',I1,X1,' ',L1,ITBAS)
          ENDIF
          CALL ACCTAB(ITBAS,'MOT',I0,X0,'MODES',L0,IP0,
     &                      'TABLE',I1,X1,' ',L1,NTBAS)
          CALL RIGTAB(NTBAS,0,IRIG,KRIG)
        ELSE
          MSOBAS = LISBAS(NBAS)
          SEGACT,MSOBAS
          IMODE = IBSTRM(2)
          SEGDES,MSOBAS
          CALL RIGMOD(IMODE,IRIG,KRIG)
        ENDIF
        IF (KRIG.EQ.0) GOTO 999
        MRIGID = KRIG
        SEGACT MRIGID
        XMATRI = IRIGEL(4,1)
        SEGACT,XMATRI*MOD
        NELRIG = RE(/3)
        DO 40 I = 1,NELRIG
          RE(1,1,I) = RE(1,1,I) * PROG(I+IP) * 0.01D0
 40     CONTINUE
        IP = IP + NELRIG
        SEGDES,XMATRI,MRIGID
        IF (KRIGI.EQ.0) THEN
          KRIGI = KRIG
        ELSE
          CALL FUSRIG(KRIGI,KRIG,IRET)
          MRIGID = KRIGI
          SEGSUP,MRIGID
          KRIGI = IRET
        ENDIF
 100  CONTINUE
      IPRIG = KRIGI

 999  CONTINUE
      IF (IBASE.NE.0) SEGDES,MBASEM
      SEGDES,MLREEL

      RETURN
      END