Télécharger amormo.eso

Retour à la liste

Numérotation des lignes :

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

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