Télécharger intevo.eso

Retour à la liste

Numérotation des lignes :

intevo
  1. C INTEVO SOURCE CB215821 23/10/18 21:15:06 11760
  2. SUBROUTINE INTEVO(IEVO,IR1,IR2,IAMOR,BETA, NEVOL)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. ************************************************************************
  6. *
  7. * I N T E V O
  8. * -----------
  9. *
  10. * FONCTION:
  11. * ---------
  12. *
  13. * INTERPOLATION D'UNE COURBE D'UNE EVOLUTION.
  14. *
  15. * MODULES UTILISES:
  16. * -----------------
  17. *
  18.  
  19. -INC PPARAM
  20. -INC CCOPTIO
  21. -INC SMEVOLL
  22. -INC SMLREEL
  23. *
  24. * PARAMETRES: (E)=ENTREE (S)=SORTIE (+ = CONTENU DANS UN COMMUN)
  25. * -----------
  26. *
  27. * IEVO (E) POINTEUR SUR UNE EVOLUTION.
  28. * IR1 (E) NUMERO DE LA PREMIERE COURBE A INTERPOLER.
  29. * IR2 (E) NUMERO DE LA DEUXIEME COURBE A INTERPOLER.
  30. * IAMOR (E) POINTEUR SUR LE LITREEL CORRESPONDANT A L'EVOLUTION.
  31. * BETA (E) AMORTISSEMENT DE LA COURBE A INTERPOLER.
  32. * NEVOL (S) POINTEUR SUR L'EVOLUTION INTERPOLEE.
  33. *
  34. *
  35. * AUTEUR, DATE DE CREATION:
  36. * -------------------------
  37. *
  38. * LIONEL VIVAN SEPTEMBRE 1988
  39. *
  40. * LANGAGE:
  41. * --------
  42. *
  43. * ESOPE + FORTRAN77
  44. *
  45. ************************************************************************
  46. *
  47. * RECHERCHE DES DEUX COURBES
  48. *
  49. MEVOLL = IEVO
  50. SEGACT MEVOLL
  51. COURB1 = IEVOLL(IR1)
  52. COURB2 = IEVOLL(IR2)
  53. *
  54. * RECUPERATION DES ABSCISSES ET DES ORDONNEES
  55. *
  56. KEVOLL = nint(COURB1 )
  57. SEGACT KEVOLL
  58. IPX1 = IPROGX
  59. IPY1 = IPROGY
  60. *
  61. KEVOLL = nint(COURB2)
  62. SEGACT KEVOLL
  63. IPX2 = IPROGX
  64. IPY2 = IPROGY
  65. *
  66. * RECUPERATION DES AMORTISSEMENTS CORRESPONDANT AUX COURBES
  67. *
  68. CALL EXTRA1(IAMOR,IR1,BETA1)
  69. CALL EXTRA1(IAMOR,IR2,BETA2)
  70. IF (IERR.NE.0) RETURN
  71. *
  72. * FUSION DES DEUX LISTREELS ABSCISSES ---> NOUVELLES ABSCISSES
  73. *
  74. CALL FUSLRE(IPX1,IPX2,IPX3)
  75. *
  76. * ON INTERPOLE OU EXTRAPOLE POUR AVOIR DES ORDONNEES IDENTIQUES
  77. *
  78. CALL DIMEN1(IPX1,LD1)
  79. CALL DIMEN1(IPX2,LD2)
  80. CALL DIMEN1(IPX3,LD3)
  81. IF (IERR.NE.0) RETURN
  82. *
  83. IF (LD3.NE.LD1) THEN
  84. C IOPERA=13 ==> LOGARITHME
  85. IOPERA=13
  86. CALL OPLRE1(IPX1,IOPERA,0,0,0.D0,IPX4,IRET)
  87. CALL OPLRE1(IPY1,IOPERA,0,0,0.D0,IPY4,IRET)
  88. CALL OPLRE1(IPX3,IOPERA,0,0,0.D0,IPX5,IRET)
  89. CALL INTE33(IPX4,IPY4,IPX5,IPY5)
  90. C IOPERA=12 ==> EXPONENTIELLE
  91. IOPERA=12
  92. CALL OPLRE1(IPY5,IOPERA,0,0,0.D0,IPY1,IRET)
  93. CALL DTLREE(IPX5)
  94. CALL DTLREE(IPY5)
  95. CALL DTLREE(IPX4)
  96. CALL DTLREE(IPY4)
  97. ENDIF
  98.  
  99. IF (LD3.NE.LD2) THEN
  100. C IOPERA=13 ==> LOGARITHME
  101. IOPERA=13
  102. CALL OPLRE1(IPX2,IOPERA,0,0,0.D0,IPX4,IRET)
  103. CALL OPLRE1(IPY2,IOPERA,0,0,0.D0,IPY4,IRET)
  104. CALL OPLRE1(IPX3,IOPERA,0,0,0.D0,IPX5,IRET)
  105. CALL INTE33(IPX4,IPY4,IPX5,IPY5)
  106. C IOPERA=12 ==> EXPONENTIELLE
  107. IOPERA=12
  108. CALL OPLRE1(IPY5,IOPERA,0,0,0.D0,IPY2,IRET)
  109. CALL DTLREE(IPX5)
  110. CALL DTLREE(IPY5)
  111. CALL DTLREE(IPX4)
  112. CALL DTLREE(IPY4)
  113. ENDIF
  114. *
  115. * ON INTERPOLE OU EXTRAPOLE SUIVANT LA VALEUR DE L'AMORTISSEMENT
  116. *
  117. ALPHA = (BETA - BETA1) / (BETA2 - BETA1)
  118. C IOPERA=13 ==> LOGARITHME
  119. IOPERA=13
  120. CALL OPLRE1(IPY1,IOPERA,0,0,0.D0,IPY4,IRET)
  121. CALL OPLRE1(IPY2,IOPERA,0,0,0.D0,IPY5,IRET)
  122. CALL INTE44(IPY4,IPY5,ALPHA,IPY6)
  123. C IOPERA=12 ==> EXPONENTIELLE
  124. IOPERA=12
  125. CALL OPLRE1(IPY6,IOPERA,0,0,0.D0,IPY3,IRET)
  126. CALL DTLREE(IPY4)
  127. CALL DTLREE(IPY5)
  128. CALL DTLREE(IPY6)
  129. *
  130. * CREATION DE LA NOUVELLE EVOLUTION
  131. *
  132. N = 1
  133. SEGINI MEVOL1
  134. NEVOL = MEVOL1
  135. *
  136. MEVOL1.IEVOLL(1) = IEVOLL(IR1)
  137. KEVOL1 = MEVOL1.IEVOLL(1)
  138. SEGACT KEVOL1
  139. KEVOL1.IPROGX = IPX3
  140. KEVOL1.IPROGY = IPY3
  141. END
  142.  
  143.  
  144.  

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