Télécharger intevo.eso

Retour à la liste

Numérotation des lignes :

  1. C INTEVO SOURCE PV 11/03/07 21:17:01 6885
  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. -INC CCOPTIO
  19. -INC SMEVOLL
  20. -INC SMLREEL
  21. *
  22. * PARAMETRES: (E)=ENTREE (S)=SORTIE (+ = CONTENU DANS UN COMMUN)
  23. * -----------
  24. *
  25. * IEVO (E) POINTEUR SUR UNE EVOLUTION.
  26. * IR1 (E) NUMERO DE LA PREMIERE COURBE A INTERPOLER.
  27. * IR2 (E) NUMERO DE LA DEUXIEME COURBE A INTERPOLER.
  28. * IAMOR (E) POINTEUR SUR LE LITREEL CORRESPONDANT A L'EVOLUTION.
  29. * BETA (E) AMORTISSEMENT DE LA COURBE A INTERPOLER.
  30. * NEVOL (S) POINTEUR SUR L'EVOLUTION INTERPOLEE.
  31. *
  32. *
  33. * AUTEUR, DATE DE CREATION:
  34. * -------------------------
  35. *
  36. * LIONEL VIVAN SEPTEMBRE 1988
  37. *
  38. * LANGAGE:
  39. * --------
  40. *
  41. * ESOPE + FORTRAN77
  42. *
  43. ************************************************************************
  44. *
  45. * RECHERCHE DES DEUX COURBES
  46. *
  47. MEVOLL = IEVO
  48. SEGACT MEVOLL
  49. COURB1 = IEVOLL(IR1)
  50. COURB2 = IEVOLL(IR2)
  51. *
  52. * RECUPERATION DES ABSCISSES ET DES ORDONNEES
  53. *
  54. KEVOLL = nint(COURB1 )
  55. SEGACT KEVOLL
  56. IPX1 = IPROGX
  57. IPY1 = IPROGY
  58. SEGDES KEVOLL
  59. *
  60. KEVOLL = nint(COURB2)
  61. SEGACT KEVOLL
  62. IPX2 = IPROGX
  63. IPY2 = IPROGY
  64. SEGDES KEVOLL
  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. CALL OPLREE(IPX1,8,IPX4)
  85. CALL OPLREE(IPY1,8,IPY4)
  86. CALL OPLREE(IPX3,8,IPX5)
  87. CALL INTE33(IPX4,IPY4,IPX5,IPY5)
  88. CALL OPLREE(IPY5,7,IPY1)
  89. CALL DTLREE(IPX5)
  90. CALL DTLREE(IPY5)
  91. CALL DTLREE(IPX4)
  92. CALL DTLREE(IPY4)
  93. ENDIF
  94. IF (LD3.NE.LD2) THEN
  95. CALL OPLREE(IPX2,8,IPX4)
  96. CALL OPLREE(IPY2,8,IPY4)
  97. CALL OPLREE(IPX3,8,IPX5)
  98. CALL INTE33(IPX4,IPY4,IPX5,IPY5)
  99. CALL OPLREE(IPY5,7,IPY2)
  100. CALL DTLREE(IPX5)
  101. CALL DTLREE(IPY5)
  102. CALL DTLREE(IPX4)
  103. CALL DTLREE(IPY4)
  104. ENDIF
  105. *
  106. * ON INTERPOLE OU EXTRAPOLE SUIVANT LA VALEUR DE L'AMORTISSEMENT
  107. *
  108. ALPHA = (BETA - BETA1) / (BETA2 - BETA1)
  109. CALL OPLREE(IPY1,8,IPY4)
  110. CALL OPLREE(IPY2,8,IPY5)
  111. CALL INTE44(IPY4,IPY5,ALPHA,IPY6)
  112. CALL OPLREE(IPY6,7,IPY3)
  113. CALL DTLREE(IPY4)
  114. CALL DTLREE(IPY5)
  115. CALL DTLREE(IPY6)
  116. *
  117. * CREATION DE LA NOUVELLE EVOLUTION
  118. *
  119. N = 1
  120. SEGINI MEVOL1
  121. NEVOL = MEVOL1
  122. *
  123. MEVOL1.IEVOLL(1) = IEVOLL(IR1)
  124. KEVOL1 = MEVOL1.IEVOLL(1)
  125. SEGACT KEVOL1
  126. KEVOL1.IPROGX = IPX3
  127. KEVOL1.IPROGY = IPY3
  128. SEGDES KEVOL1
  129. *
  130. SEGDES,MEVOL1,MEVOLL
  131. *
  132. END
  133.  
  134.  
  135.  

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