C AMORMO SOURCE FANDEUR 11/07/19 21:15:16 7042 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