Télécharger envspe.eso

Retour à la liste

Numérotation des lignes :

envspe
  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.  
  50. -INC PPARAM
  51. -INC CCOPTIO
  52. -INC SMTABLE
  53. *
  54. * VARIABLES:
  55. * ----------
  56. *
  57. * IPEVOL = SPECTRES D'OSCILLATEUR (OBJETS "EVOLUTIO").
  58. * EN DERNIERE POSITION, ENVELOPPE.
  59. * IPAMOR = VALEURS DES AMORTISSEMENTS DE CHAQUE SPECTRE (OBJETS
  60. * "LISTREEL").
  61. *
  62. REAL*8 X,XVALRE
  63. CHARACTER*1 C
  64. CHARACTER*8 TYPOBJ,CHARRE
  65. LOGICAL L,LOGIN,LOGRE
  66. SEGMENT,MSPECT
  67. INTEGER IPEVOL(NBSPEC+1),IPAMOR(NBSPEC+1)
  68. ENDSEGMENT
  69. *
  70. * AUTEUR, DATE DE CREATION:
  71. * -------------------------
  72. *
  73. * PASCAL MANIGOT 13 SEPTEMBRE 1988
  74. *
  75. * LANGAGE:
  76. * --------
  77. *
  78. * ESOPE + FORTRAN77 + EXTENSION: DECLARATION "REAL*8".
  79. *
  80. ************************************************************************
  81. *
  82. I=0
  83. X=0.D0
  84. L=.FALSE.
  85.  
  86. CALL LIROBJ ('TABLE ',ISPEC,1,IRETOU)
  87. IF (IERR .NE. 0) RETURN
  88. *
  89. * NOMBRE DE SPECTRES D'OSCILLATEURS FOURNI:
  90. CALL DIMEN7 (ISPEC, NBSPEC)
  91. IF (NBSPEC .LE. 0) THEN
  92. CALL ERREUR (215)
  93. RETURN
  94. END IF
  95. *
  96. * LA TABLE EST SUPPOSEE ETRE INDICEE PAR DES ENTIERS, A PARTIR DE 1.
  97. * ... CE QUE L'ON VA VERIFIER TOUT DE SUITE, EN MEME TEMPS QUE L'ON
  98. * RANGE LES SPECTRES SOUS UNE FORME INFORMATIQUEMENT PLUS PRATIQUE.
  99. *
  100. SEGINI,MSPECT
  101. *
  102. DO 100 IB=1,NBSPEC
  103. TYPOBJ = 'TABLE '
  104. CALL ACCTAB(ISPEC,'ENTIER ',IB,0.D0,C,LOGIN ,0,TYPOBJ,
  105. C IVALRE,XVALRE,CHARRE,LOGRE,ICOUR)
  106. IF (TYPOBJ.NE.'TABLE ') THEN
  107. MOTERR(1:8)=TYPOBJ(1:8)
  108. CALL ERREUR(39)
  109. ENDIF
  110. IF (IERR .NE. 0) RETURN
  111. TYPOBJ = 'EVOLUTIO'
  112. CALL ACCTAB(ICOUR,'MOT ',0,0.D0,'SPECTRE',LOGIN ,0,TYPOBJ,
  113. C IVALRE,XVALRE,CHARRE,LOGRE,IPTR)
  114. IF (TYPOBJ.NE.'EVOLUTIO') THEN
  115. MOTERR(1:8)=TYPOBJ(1:8)
  116. CALL ERREUR(39)
  117. ENDIF
  118. IF (IERR .NE. 0) RETURN
  119. IPEVOL(IB) = IPTR
  120. TYPOBJ = 'LISTREEL'
  121. CALL ACCTAB(ICOUR,'MOT ',0,0.D0,'AMORTISSEMENT',LOGIN ,0,
  122. C TYPOBJ,IVALRE,XVALRE,CHARRE,LOGRE,IPTR)
  123. IF (TYPOBJ.NE.'LISTREEL') THEN
  124. MOTERR(1:8)=TYPOBJ(1:8)
  125. CALL ERREUR(39)
  126. ENDIF
  127. IF (IERR .NE. 0) RETURN
  128. IPAMOR(IB) = IPTR
  129. 100 CONTINUE
  130. * END DO
  131. *
  132. * CREATION DU SPECTRE ENVELOPPE:
  133. CALL ENVSP1 (MSPECT)
  134. IF (IERR .NE. 0) RETURN
  135. *
  136. CALL CRTABL(MTABLE)
  137. SEGACT,MSPECT
  138. IPEV0L = IPEVOL(NBSPEC+1)
  139. CALL ECCTAB (MTABLE,'MOT ',I,X,'SPECTRE',L,I,
  140. & 'EVOLUTIO',I,X,C,L,IPEV0L)
  141. IPAM0R = IPAMOR(NBSPEC+1)
  142. CALL ECCTAB (MTABLE,'MOT ',I,X,'AMORTISSEMENT',L,I,
  143. & 'LISTREEL',I,X,C,L,IPAM0R)
  144. *
  145. SEGSUP,MSPECT
  146. SEGDES,MTABLE
  147. *
  148. * ECRITURE DU SPECTRE ENVELOPPE:
  149. CALL ECROBJ ('TABLE ',MTABLE)
  150. *
  151. END
  152.  
  153.  
  154.  

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