Télécharger la plaquette Cast3M


fr en

Télécharger amormo.eso

Retour à la liste

Numérotation des lignes : 

amormo

  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.  
  22. -INC PPARAM
  23. -INC CCOPTIO
  24.  
  25. -INC SMLREEL
  26. -INC SMRIGID
  27. -INC SMBASEM
  28. -INC SMSOLUT
  29. *
  30.       LOGICAL BASMUL
  31.  
  32.       LOGICAL L0,L1
  33.       CHARACTER*8 TYPRET,CHARRE
  34.  
  35.       MLREEL = IPROG
  36.       SEGACT,MLREEL
  37.       LON = PROG(/1)
  38.  
  39.       IP = 0
  40.  
  41.       IF (IBASE.LE.0) THEN
  42. c* equivalent a IF (ITABL.GT.0) THEN
  43.         IF (BASMUL) THEN
  44.           ITBAM = ITABL
  45.           IB = 0
  46.  10       CONTINUE
  47.           IB = IB + 1
  48.           TYPRET = ' '
  49.           CALL ACCTAB(ITBAM,'ENTIER',IB,X0,' ',L0,IP0,
  50.      &                      TYPRET,I1,X1,CHARRE,L1,IBAS)
  51.           IF (IBAS.NE.0 .AND. TYPRET.EQ.'TABLE   ') GOTO 10
  52.           NBASE = IB - 1
  53.           DO NBAS = 1, NBASE
  54.             CALL ACCTAB(ITBAM,'ENTIER',NBAS,X0,' ',L0,IP0,
  55.      &                        'TABLE',I1,X1,CHARRE,L1,ITBAS)
  56.             CALL ACCTAB(ITBAS,'MOT',I0,X0,'MODES',L0,IP0,
  57.      &                        'TABLE',I1,X1,CHARRE,L1,NTBAS)
  58.             IB = 0
  59.  14         CONTINUE
  60.             IB = IB + 1
  61.             TYPRET = ' '
  62.             CALL ACCTAB(NTBAS,'ENTIER',IB,X0,' ',L0,IP0,
  63.      &                        TYPRET,I1,X1,CHARRE,L1,ITMOD)
  64.             IF (ITMOD.NE.0 .AND. TYPRET.EQ.'TABLE   ') GOTO 14
  65.             IP = IP + IB - 1
  66.           ENDDO
  67.         ELSE
  68.           ITBAS = ITABL
  69.           NBASE = 1
  70.           CALL ACCTAB(ITBAS,'MOT',I0,X0,'MODES',L0,IP0,
  71.      &                      'TABLE',I1,X1,' ',L1,NTBAS)
  72.           IB = 0
  73.  16       CONTINUE
  74.           IB = IB + 1
  75.           TYPRET = ' '
  76.           CALL ACCTAB(NTBAS,'ENTIER',IB,X0,' ',L0,IP0,
  77.      &                      TYPRET,I1,X1,CHARRE,L1,ITMOD)
  78.           IF (ITMOD.NE.0 .AND. TYPRET.EQ.'TABLE   ') GOTO 16
  79.           IP = IP + IB - 1
  80.         ENDIF
  81.       ELSE
  82.         MBASEM = IBASE
  83.         SEGACT,MBASEM
  84.         NBASE = LISBAS(/1)
  85.         DO 20 NBAS = 1,NBASE
  86.           MSOBAS = LISBAS(NBAS)
  87.           SEGACT,MSOBAS
  88.           MSOLUT = IBSTRM(2)
  89.           SEGACT,MSOLUT
  90.           MSOLEN = MSOLIS(4)
  91.           SEGACT,MSOLEN
  92.           IP = IP + ISOLEN(/1)
  93.           SEGDES,MSOLEN,MSOLUT,MSOBAS
  94.  20     CONTINUE
  95.       ENDIF
  96.  
  97. *   le nb de modes de la base n'est pas egal au nb d'amortissements
  98.       IF (LON.NE.IP) THEN
  99.         CALL ERREUR(209)
  100.         GOTO 999
  101.       ENDIF
  102.  
  103.       KRIGI = 0
  104.       IRIG = 3
  105.       IP = 0
  106.       DO 100 NBAS = 1,NBASE
  107.         IF (IBASE.EQ.0) THEN
  108.           IF ( BASMUL ) THEN
  109.             CALL ACCTAB(ITBAM,'ENTIER',NBAS,X0,' ',L0,IP0,
  110.      &                        'TABLE',I1,X1,' ',L1,ITBAS)
  111.           ENDIF
  112.           CALL ACCTAB(ITBAS,'MOT',I0,X0,'MODES',L0,IP0,
  113.      &                      'TABLE',I1,X1,' ',L1,NTBAS)
  114.           CALL RIGTAB(NTBAS,0,IRIG,KRIG)
  115.         ELSE
  116.           MSOBAS = LISBAS(NBAS)
  117.           SEGACT,MSOBAS
  118.           IMODE = IBSTRM(2)
  119.           SEGDES,MSOBAS
  120.           CALL RIGMOD(IMODE,IRIG,KRIG)
  121.         ENDIF
  122.         IF (KRIG.EQ.0) GOTO 999
  123.         MRIGID = KRIG
  124.         SEGACT MRIGID
  125.         XMATRI = IRIGEL(4,1)
  126.         SEGACT,XMATRI*MOD
  127.         NELRIG = RE(/3)
  128.         DO 40 I = 1,NELRIG
  129.           RE(1,1,I) = RE(1,1,I) * PROG(I+IP) * 0.01D0
  130.  40     CONTINUE
  131.         IP = IP + NELRIG
  132.         SEGDES,XMATRI,MRIGID
  133.         IF (KRIGI.EQ.0) THEN
  134.           KRIGI = KRIG
  135.         ELSE
  136.           CALL FUSRIG(KRIGI,KRIG,IRET)
  137.           MRIGID = KRIGI
  138.           SEGSUP,MRIGID
  139.           KRIGI = IRET
  140.         ENDIF
  141.  100  CONTINUE
  142.       IPRIG = KRIGI
  143.  
  144.  999  CONTINUE
  145.       IF (IBASE.NE.0) SEGDES,MBASEM
  146.       SEGDES,MLREEL
  147.  
  148.       RETURN
  149.       END
  150.  
  151.  
  152.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales