Télécharger la plaquette Cast3M


fr en

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