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 : * 67 : CALL EXTRA1(IAMOR,IR1,BETA1) 67 : CALL EXTRA1(IAMOR,IR2,BETA2) 68 : IF (IERR.NE.0) RETURN 69 : * 70 : * FUSION DES DEUX LISTREELS ABSCISSES ---> NOUVELLES ABSCISSES 71 : * 71 : CALL FUSLRE(IPX1,IPX2,IPX3) 72 : * 73 : * ON INTERPOLE OU EXTRAPOLE POUR AVOIR DES ORDONNEES IDENTIQUES 74 : * 74 : CALL DIMEN1(IPX1,LD1) 74 : CALL DIMEN1(IPX2,LD2) 74 : CALL DIMEN1(IPX3,LD3) 75 : IF (IERR.NE.0) RETURN 76 : * 77 : IF (LD3.NE.LD1) THEN 77 : CALL OPLREE(IPX1,8,IPX4) 77 : CALL OPLREE(IPY1,8,IPY4) 77 : CALL OPLREE(IPX3,8,IPX5) 77 : CALL INTE33(IPX4,IPY4,IPX5,IPY5) 77 : CALL OPLREE(IPY5,7,IPY1) 77 : CALL DTLREE(IPX5) 77 : CALL DTLREE(IPY5) 77 : CALL DTLREE(IPX4) 77 : CALL DTLREE(IPY4) 78 : ENDIF 79 : IF (LD3.NE.LD2) THEN 79 : CALL OPLREE(IPX2,8,IPX4) 79 : CALL OPLREE(IPY2,8,IPY4) 79 : CALL OPLREE(IPX3,8,IPX5) 79 : CALL INTE33(IPX4,IPY4,IPX5,IPY5) 79 : CALL OPLREE(IPY5,7,IPY2) 79 : CALL DTLREE(IPX5) 79 : CALL DTLREE(IPY5) 79 : CALL DTLREE(IPX4) 79 : CALL DTLREE(IPY4) 80 : ENDIF 81 : * 82 : * ON INTERPOLE OU EXTRAPOLE SUIVANT LA VALEUR DE L'AMORTISSEMENT 83 : * 84 : ALPHA = (BETA - BETA1) / (BETA2 - BETA1) 84 : CALL OPLREE(IPY1,8,IPY4) 84 : CALL OPLREE(IPY2,8,IPY5) 84 : CALL INTE44(IPY4,IPY5,ALPHA,IPY6) 84 : CALL OPLREE(IPY6,7,IPY3) 84 : CALL DTLREE(IPY4) 84 : CALL DTLREE(IPY5) 84 : CALL DTLREE(IPY6) 85 : * 86 : * CREATION DE LA NOUVELLE EVOLUTION 87 : * 88 : N = 1 89 : SEGINI MEVOL1 90 : NEVOL = MEVOL1 91 : * 92 : MEVOL1.IEVOLL(1) = IEVOLL(IR1) 93 : KEVOL1 = MEVOL1.IEVOLL(1) 94 : SEGACT KEVOL1 95 : KEVOL1.IPROGX = IPX3 96 : KEVOL1.IPROGY = IPY3 97 : SEGDES KEVOL1 98 : * 99 : SEGDES,MEVOL1,MEVOLL 100 : * 101 : END 102 : 103 :
© Cast3M 2003 - All rights reserved.
Disclaimer