Télécharger envsp1.eso

Retour à la liste

Numérotation des lignes :

  1. C ENVSP1 SOURCE CHAT 05/01/12 23:40:54 5004
  2. SUBROUTINE ENVSP1 (MSPECT)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. ************************************************************************
  6. *
  7. * E N V S P 1
  8. * -----------
  9. *
  10. * FONCTION:
  11. * ---------
  12. *
  13. * CREER LE SPECTRE ENVELOPPE D'UNE SERIE DE SPECTRES D'OSCILLATEURS.
  14. *
  15. * CET OPERATEUR EST TRES ATTACHE A LA NOTION DE SPECTRE CAR IL
  16. * UTILISE L'INTERPOLATION LINEAIRE OU LOGARITHMIQUE DE FACON BIEN
  17. * SPECIFIQUE.
  18. *
  19. * MODULES UTILISES:
  20. * -----------------
  21. *
  22. -INC CCOPTIO
  23. -INC SMEVOLL
  24. -INC SMLREEL
  25. *
  26. * PARAMETRES: (E)=ENTREE (S)=SORTIE (+ = CONTENU DANS UN COMMUN)
  27. * -----------
  28. *
  29. * MSPECT (E) SPECTRES D'OSCILLATEURS EN POSITIONS 1 A "N".
  30. * (S) SPECTRE ENVELOPPE EN POSITION "N+1".
  31. *
  32. SEGMENT,MSPECT
  33. INTEGER IPEVOL(NBSPEC+1),IPAMOR(NBSPEC+1)
  34. ENDSEGMENT
  35. * IPEVOL = SPECTRES D'OSCILLATEUR (OBJETS "EVOLUTIO").
  36. * EN DERNIERE POSITION, ENVELOPPE.
  37. * IPAMOR = VALEURS DES AMORTISSEMENTS DE CHAQUE SPECTRE (OBJETS
  38. * "LISTREEL").
  39. *
  40. * VARIABLES:
  41. * ----------
  42. *
  43. PARAMETER (TOLER = 1.E-6)
  44. *
  45. * AUTEUR, DATE DE CREATION:
  46. * -------------------------
  47. *
  48. * PASCAL MANIGOT 13 SEPTEMBRE 1988
  49. *
  50. * LANGAGE:
  51. * --------
  52. *
  53. * ESOPE + FORTRAN77 + EXTENSION: DECLARATION "REAL*8".
  54. *
  55. ************************************************************************
  56. *
  57. SEGACT,MSPECT*MOD
  58. NBSPEC = IPEVOL(/1) - 1
  59. *
  60. IF (NBSPEC .LE. 0) RETURN
  61. *
  62. *
  63. * CREATION DE LA LISTE DES AMORTISSEMENTS DU SPECTRE ENVELOPPE:
  64. *
  65. IPAMO9 = IPAMOR(1)
  66. *
  67. DO 100 IB=2,NBSPEC
  68. IPAMO1 = IPAMO9
  69. IPAM0R = IPAMOR(IB)
  70. CALL FUSLRE (IPAMO1,IPAM0R, IPAMO9)
  71. IF (IB .GT. 2) THEN
  72. CALL DTLREE (IPAMO1)
  73. END IF
  74. 100 CONTINUE
  75. * END DO
  76. *
  77. IPAMOR(NBSPEC+1) = IPAMO9
  78. *
  79. CALL DIMEN1(IPAMO9,NBAMOR)
  80. *
  81. * CREATION DE L'EVOLUTION DE L'ENVELOPPE
  82. *
  83. N = NBAMOR
  84. SEGINI MEVOLL
  85. ITRUC = MEVOLL
  86. ITYEVO = 'REEL '
  87. *
  88. * RECHERCHE DES ENVELOPPES, POUR CHAQUE AMORTISSEMENT
  89. *
  90. DO 200 IB = 1,NBAMOR
  91. CALL EXTRA1(IPAMO9,IB,BETAI)
  92. *
  93. * CREATION OBJET EVOLUTION A BETA CONSTANT
  94. *
  95. N = NBSPEC
  96. SEGINI MEVOL1
  97. IEVOLB = MEVOL1
  98. *
  99. DO 300 IS = 1,NBSPEC
  100. NAMOR = IPAMOR(IS)
  101. NEVOL = IPEVOL(IS)
  102. MLREEL = NAMOR
  103. SEGACT MLREEL
  104. LDIM = PROG(/1)
  105. *
  106. * TEST POUR SAVOIR SI BETAI EST DANS NAMOR
  107. *
  108. CALL PLACE3(PROG,1,LDIM,BETAI,IR,AR)
  109. SEGDES MLREEL
  110. IF (AR.LT.TOLER) THEN
  111. * IL Y A UNE COURBE CORRESPONDANT A BETAI
  112. IF (IR.EQ.0) THEN
  113. IR = IR + 1
  114. ENDIF
  115. MEVOL2 = NEVOL
  116. SEGACT MEVOL2
  117. MEVOL1.IEVOLL(IS) = MEVOL2.IEVOLL(IR)
  118. SEGDES MEVOL2
  119. ELSE
  120. * INTERPOLATION
  121. IF (IR.EQ.0) THEN
  122. IR1 = 1
  123. IR2 = 2
  124. ELSE IF (IR.EQ.LDIM) THEN
  125. IR1 = LDIM - 1
  126. IR2 = LDIM
  127. ELSE
  128. IR1 = IR
  129. IR2 = IR + 1
  130. ENDIF
  131. CALL INTEVO(NEVOL,IR1,IR2,NAMOR,BETAI,NEVOL3)
  132. MEVOL2 = NEVOL3
  133. SEGACT MEVOL2
  134. MEVOL1.IEVOLL(IS) = MEVOL2.IEVOLL(1)
  135. SEGSUP MEVOL2
  136. ENDIF
  137. 300 CONTINUE
  138. * END DO
  139. *
  140. SEGDES MEVOL1
  141. IEVOL = MAXEVO(IEVOLB)
  142. SEGSUP MEVOL1
  143. *
  144. MEVOL2 = IEVOL
  145. SEGACT MEVOL2
  146. IEVOLL(IB) = MEVOL2.IEVOLL(1)
  147. SEGSUP MEVOL2
  148. *
  149. 200 CONTINUE
  150. * END DO
  151. *
  152. * ON RANGE L'EVOLUTION
  153. *
  154. IPEVOL(NBSPEC+1) = ITRUC
  155. *
  156. SEGDES MSPECT
  157. SEGDES MEVOLL
  158. *
  159. END
  160.  
  161.  
  162.  

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