Télécharger envspe.eso

Retour à la liste

Numérotation des lignes :

  1. C ENVSPE SOURCE CB215821 16/04/15 21:15:20 8907
  2. SUBROUTINE ENVSPE
  3. ************************************************************************
  4. *
  5. * E N V S P E
  6. * -----------
  7. *
  8. * SOUS-PROGRAMME ASSOCIE A L'OPERATEUR "ENVELOPPE"
  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. * PHRASE D'APPEL (EN GIBIANE):
  20. * ----------------------------
  21. *
  22. * ENVLOP = 'ENVELOPPE' LIST_SPO ;
  23. *
  24. * OPERANDES ET RESULTATS:
  25. * -----------------------
  26. *
  27. * LIST_SPO (TABLE) CONTIENT LES DIFFERENTS SPECTRES
  28. * -------- D'OSCILLATEUR (PAS FORCEMENT DEFINIS AUX
  29. * MEMES FREQUENCES, NI POUR LES MEMES
  30. * AMORTISSEMENTS):
  31. * LIST_SPO I 'SPECTRE = OBJET "EVOLUTIO" REPRESENTANT LE
  32. * I-EME "SPO".
  33. * LIST_SPO I 'AMORTISSEMENT' = OBJET "LISTREEL" DONNANT LES
  34. * AMORTISSEMENTS POUR CHAQUE COURBE
  35. * DE L'OBJET "EVOLUTIO" NUMERO "I".
  36. *
  37. * ENVLOP (TABLE) CONTIENT LE SPECTRE ENVELOPPE:
  38. * ------
  39. * LIST_SPO 'SPECTRE' = OBJET "EVOLUTIO" REPRESENTANT LE
  40. * SPECTRE.
  41. * LIST_SPO 'AMORTISSEMENT' = OBJET "LISTREEL" DONNANT LES
  42. * AMORTISSEMENTS POUR CHAQUE COURBE
  43. * DE L'OBJET "EVOLUTIO".
  44. *
  45. * MODULES UTILISES:
  46. * -----------------
  47. *
  48. IMPLICIT INTEGER(I-N)
  49. -INC CCOPTIO
  50. -INC SMTABLE
  51. *
  52. * VARIABLES:
  53. * ----------
  54. *
  55. * IPEVOL = SPECTRES D'OSCILLATEUR (OBJETS "EVOLUTIO").
  56. * EN DERNIERE POSITION, ENVELOPPE.
  57. * IPAMOR = VALEURS DES AMORTISSEMENTS DE CHAQUE SPECTRE (OBJETS
  58. * "LISTREEL").
  59. *
  60. REAL*8 X,XVALRE
  61. CHARACTER*1 C
  62. CHARACTER*8 TYPOBJ,CHARRE
  63. LOGICAL L,LOGIN,LOGRE
  64. SEGMENT,MSPECT
  65. INTEGER IPEVOL(NBSPEC+1),IPAMOR(NBSPEC+1)
  66. ENDSEGMENT
  67. *
  68. * AUTEUR, DATE DE CREATION:
  69. * -------------------------
  70. *
  71. * PASCAL MANIGOT 13 SEPTEMBRE 1988
  72. *
  73. * LANGAGE:
  74. * --------
  75. *
  76. * ESOPE + FORTRAN77 + EXTENSION: DECLARATION "REAL*8".
  77. *
  78. ************************************************************************
  79. *
  80. I=0
  81. X=0.D0
  82. L=.FALSE.
  83.  
  84. CALL LIROBJ ('TABLE ',ISPEC,1,IRETOU)
  85. IF (IERR .NE. 0) RETURN
  86. *
  87. * NOMBRE DE SPECTRES D'OSCILLATEURS FOURNI:
  88. CALL DIMEN7 (ISPEC, NBSPEC)
  89. IF (NBSPEC .LE. 0) THEN
  90. CALL ERREUR (215)
  91. RETURN
  92. END IF
  93. *
  94. * LA TABLE EST SUPPOSEE ETRE INDICEE PAR DES ENTIERS, A PARTIR DE 1.
  95. * ... CE QUE L'ON VA VERIFIER TOUT DE SUITE, EN MEME TEMPS QUE L'ON
  96. * RANGE LES SPECTRES SOUS UNE FORME INFORMATIQUEMENT PLUS PRATIQUE.
  97. *
  98. SEGINI,MSPECT
  99. *
  100. DO 100 IB=1,NBSPEC
  101. TYPOBJ = 'TABLE '
  102. CALL ACCTAB(ISPEC,'ENTIER ',IB,0.D0,C,LOGIN ,0,TYPOBJ,
  103. C IVALRE,XVALRE,CHARRE,LOGRE,ICOUR)
  104. IF (TYPOBJ.NE.'TABLE ') THEN
  105. MOTERR(1:8)=TYPOBJ(1:8)
  106. CALL ERREUR(39)
  107. ENDIF
  108. IF (IERR .NE. 0) RETURN
  109. TYPOBJ = 'EVOLUTIO'
  110. CALL ACCTAB(ICOUR,'MOT ',0,0.D0,'SPECTRE',LOGIN ,0,TYPOBJ,
  111. C IVALRE,XVALRE,CHARRE,LOGRE,IPTR)
  112. IF (TYPOBJ.NE.'EVOLUTIO') THEN
  113. MOTERR(1:8)=TYPOBJ(1:8)
  114. CALL ERREUR(39)
  115. ENDIF
  116. IF (IERR .NE. 0) RETURN
  117. IPEVOL(IB) = IPTR
  118. TYPOBJ = 'LISTREEL'
  119. CALL ACCTAB(ICOUR,'MOT ',0,0.D0,'AMORTISSEMENT',LOGIN ,0,
  120. C TYPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IPTR)
  121. IF (TYPOBJ.NE.'LISTREEL') THEN
  122. MOTERR(1:8)=TYPOBJ(1:8)
  123. CALL ERREUR(39)
  124. ENDIF
  125. IF (IERR .NE. 0) RETURN
  126. IPAMOR(IB) = IPTR
  127. 100 CONTINUE
  128. * END DO
  129. *
  130. * CREATION DU SPECTRE ENVELOPPE:
  131. CALL ENVSP1 (MSPECT)
  132. IF (IERR .NE. 0) RETURN
  133. *
  134. CALL CRTABL(MTABLE)
  135. SEGACT,MSPECT
  136. IPEV0L = IPEVOL(NBSPEC+1)
  137. CALL ECCTAB (MTABLE,'MOT ',I,X,'SPECTRE',L,I,
  138. & 'EVOLUTIO',I,X,C,L,IPEV0L)
  139. IPAM0R = IPAMOR(NBSPEC+1)
  140. CALL ECCTAB (MTABLE,'MOT ',I,X,'AMORTISSEMENT',L,I,
  141. & 'LISTREEL',I,X,C,L,IPAM0R)
  142. *
  143. SEGSUP,MSPECT
  144. SEGDES,MTABLE
  145. *
  146. * ECRITURE DU SPECTRE ENVELOPPE:
  147. CALL ECROBJ ('TABLE ',MTABLE)
  148. *
  149. END
  150.  
  151.  
  152.  

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