Esope source files

   1 : C AMORMO    SOURCE    FANDEUR   11/07/19    21:15:16     7042           
   2 : 
   3 :       SUBROUTINE AMORMO (IPROG,IBASE,ITABL,BASMUL, IPRIG)
   4 : 
   5 : C***********************************************************************
   6 : C                                                                      *
   7 : C      FABRICATION DE LA MATRICE D'AMORTISSEMENT MODAL                 *
   8 : C      SYNTAXE : AMO1= AMOR BASE PROG ;                                *
   9 : C        AMO1   MATRICE D'AMORTISSEMENT                                *
  10 : C        BASE   OBJET DE TYPE BASE MODALE                              *
  11 : C        PROG   OBJET DE TYPE MLREEL LISTE DES                         *
  12 : C        COEFFICIENTS D'AMORTISSEMENT REDUITS (%)                      *
  13 : C        CREATION    : 26/11/86                                        *
  14 : C        PROGRAMMEUR : GUILBAUD                                        *
  15 : C                                                                      *
  16 : C***********************************************************************
  17 : 
  18 :       IMPLICIT INTEGER(I-N)
  19 :       IMPLICIT REAL*8 (A-H,O-Z)
  20 : 
  21 : -INC CCOPTIO
  22 : 
  23 : -INC SMLREEL
  24 : -INC SMRIGID
  25 : -INC SMBASEM
  26 : -INC SMSOLUT
  27 : *
  28 :       LOGICAL BASMUL
  29 : 
  30 :       LOGICAL L0,L1
  31 :       CHARACTER*8 TYPRET,CHARRE
  32 : 
  33 :       MLREEL = IPROG
  34 :       SEGACT,MLREEL
  35 :       LON = PROG(/1)
  36 : 
  37 :       IP = 0
  38 : 
  39 :       IF (IBASE.LE.0) THEN
  40 : c* equivalent a IF (ITABL.GT.0) THEN
  41 :         IF (BASMUL) THEN
  42 :           ITBAM = ITABL
  43 :           IB = 0
  44 :  10       CONTINUE
  45 :           IB = IB + 1
  46 :           TYPRET = ' '
  46 :           CALL ACCTAB(ITBAM,'ENTIER',IB,X0,' ',L0,IP0,
  47 :      &                      TYPRET,I1,X1,CHARRE,L1,IBAS)
  48 :           IF (IBAS.NE.0 .AND. TYPRET.EQ.'TABLE   ') GOTO 10
  49 :           NBASE = IB - 1
  50 :           DO NBAS = 1, NBASE
  50 :             CALL ACCTAB(ITBAM,'ENTIER',NBAS,X0,' ',L0,IP0,
  51 :      &                        'TABLE',I1,X1,CHARRE,L1,ITBAS)
  51 :             CALL ACCTAB(ITBAS,'MOT',I0,X0,'MODES',L0,IP0,
  52 :      &                        'TABLE',I1,X1,CHARRE,L1,NTBAS)
  53 :             IB = 0
  54 :  14         CONTINUE
  55 :             IB = IB + 1
  56 :             TYPRET = ' '
  56 :             CALL ACCTAB(NTBAS,'ENTIER',IB,X0,' ',L0,IP0,
  57 :      &                        TYPRET,I1,X1,CHARRE,L1,ITMOD)
  58 :             IF (ITMOD.NE.0 .AND. TYPRET.EQ.'TABLE   ') GOTO 14
  59 :             IP = IP + IB - 1
  60 :           ENDDO
  61 :         ELSE
  62 :           ITBAS = ITABL
  63 :           NBASE = 1
  63 :           CALL ACCTAB(ITBAS,'MOT',I0,X0,'MODES',L0,IP0,
  64 :      &                      'TABLE',I1,X1,' ',L1,NTBAS)
  65 :           IB = 0
  66 :  16       CONTINUE
  67 :           IB = IB + 1
  68 :           TYPRET = ' '
  68 :           CALL ACCTAB(NTBAS,'ENTIER',IB,X0,' ',L0,IP0,
  69 :      &                      TYPRET,I1,X1,CHARRE,L1,ITMOD)
  70 :           IF (ITMOD.NE.0 .AND. TYPRET.EQ.'TABLE   ') GOTO 16
  71 :           IP = IP + IB - 1
  72 :         ENDIF
  73 :       ELSE
  74 :         MBASEM = IBASE
  75 :         SEGACT,MBASEM
  76 :         NBASE = LISBAS(/1)
  77 :         DO 20 NBAS = 1,NBASE
  78 :           MSOBAS = LISBAS(NBAS)
  79 :           SEGACT,MSOBAS
  80 :           MSOLUT = IBSTRM(2)
  81 :           SEGACT,MSOLUT
  82 :           MSOLEN = MSOLIS(4)
  83 :           SEGACT,MSOLEN
  84 :           IP = IP + ISOLEN(/1)
  85 :           SEGDES,MSOLEN,MSOLUT,MSOBAS
  86 :  20     CONTINUE
  87 :       ENDIF
  88 : 
  89 : *   le nb de modes de la base n'est pas egal au nb d'amortissements
  90 :       IF (LON.NE.IP) THEN
  90 :         CALL ERREUR(209)
  91 :         GOTO 999
  92 :       ENDIF
  93 : 
  94 :       KRIGI = 0
  95 :       IRIG = 3
  96 :       IP = 0
  97 :       DO 100 NBAS = 1,NBASE
  98 :         IF (IBASE.EQ.0) THEN
  99 :           IF ( BASMUL ) THEN
  99 :             CALL ACCTAB(ITBAM,'ENTIER',NBAS,X0,' ',L0,IP0,
 100 :      &                        'TABLE',I1,X1,' ',L1,ITBAS)
 101 :           ENDIF
 101 :           CALL ACCTAB(ITBAS,'MOT',I0,X0,'MODES',L0,IP0,
 102 :      &                      'TABLE',I1,X1,' ',L1,NTBAS)
 102 :           CALL RIGTAB(NTBAS,0,IRIG,KRIG)
 103 :         ELSE
 104 :           MSOBAS = LISBAS(NBAS)
 105 :           SEGACT,MSOBAS
 106 :           IMODE = IBSTRM(2)
 107 :           SEGDES,MSOBAS
 107 :           CALL RIGMOD(IMODE,IRIG,KRIG)
 108 :         ENDIF
 109 :         IF (KRIG.EQ.0) GOTO 999
 110 :         MRIGID = KRIG
 111 :         SEGACT MRIGID
 112 :         XMATRI = IRIGEL(4,1)
 113 :         SEGACT,XMATRI*MOD
 114 :         NELRIG = RE(/3)
 115 :         DO 40 I = 1,NELRIG
 116 :           RE(1,1,I) = RE(1,1,I) * PROG(I+IP) * 0.01D0
 117 :  40     CONTINUE
 118 :         IP = IP + NELRIG
 119 :         SEGDES,XMATRI,MRIGID
 120 :         IF (KRIGI.EQ.0) THEN
 121 :           KRIGI = KRIG
 122 :         ELSE
 122 :           CALL FUSRIG(KRIGI,KRIG,IRET)
 123 :           MRIGID = KRIGI
 124 :           SEGSUP,MRIGID
 125 :           KRIGI = IRET
 126 :         ENDIF
 127 :  100  CONTINUE
 128 :       IPRIG = KRIGI
 129 : 
 130 :  999  CONTINUE
 131 :       IF (IBASE.NE.0) SEGDES,MBASEM
 132 :       SEGDES,MLREEL
 133 : 
 134 :       RETURN
 135 :       END
 136 : 
 137 :