PCTuning fórum

Kód: Vybrat vše

                Program Fibonachiho metoda


        implicit none
        double precision Abig,Ce,Cl,Cp,Cpa,Fa,deltaHc,P,deltaT,U,Vt
        double precision Wd,Wo,min,x1,x2,I
        
        open(1,file='data.txt')
        read(1,*) Abig,Ce,Cl,Cp,Cpa,Fa,deltaHc,P,deltaT,U,Vt,Wd,Wo

        write(*,*) 'Zvolte interval x1,x2, kde bude extrem vypocitan'
        read(*,*) x1,x2
        write(*,*) 'Zvolte interval neurcitosti'
        read(*,*) I


        call fib(x1,x2,I,min)
        read(*,*)
        end


        subroutine model(x,y)
        implicit none

        double precision Abig,Ce,Cl,Cp,Cpa,Fa,deltaHc,P,deltaT,U,Vt,Wd
        double precision Wo,C,beta,first,scnd,thrd,T,x,y

        beta=(-0.2631125+0.0028958*T)*Wo**(-0.2368125+0.000966*T)
        first=(1.767*log(Wo/Wd))/(beta*Vt)
        scnd=(Fa*Cpa+U*Abig)*(T-deltaT)*Cp
        thrd=(deltaHc+P*Ce+Cl)

        C=(first*scnd)/thrd
        end

        subroutine fcislo(x,y)
        double precision x,y
        y=((((1+5**0.5)/2)**(x+1)-((1-5**0.5)/2)**(x+1))/5**0.5)
        end
               
c       Fibonachiho metoda
        subroutine fib(x1,x2,I,min)
        implicit none
        double precision x1,x2,I,min,r,x,y,n,k,d1,d2,a,b,c,d,podil
        integer hodnota

        do n=1,10000
         call fcislo(n,y)
          r=(x2-x1)/I*1
         if(y.GT.r) goto 53
        enddo        
53      write(*,*) 'pocet kroku metody',(n-1)

        hodnota=1
        do k=n,2,-1
        call fcislo(k-1,d1)
        call fcislo(k,d2)
        podil=d1/d2
        I=x2-x1
        a=x2-podil*I
        b=x1+podil*I
        if (a.EQ.c) then
               a=a-I/6
               c=c+I/6
         endif

        if (hodnota.EQ.1.AND.hodnota.EQ.2) call model(a,b)
        if (hodnota.EQ.1.AND.hodnota.EQ.3) call model(c,d)


        if (b.LT.d) then
              x2=c
              c=b
              hodnota=2
         elseif (b.GT.d) then
              x1=a
              b=c
              hodnota=3
         endif
        enddo

        write(*,*) 'Konecny interval',x1,x2
        write(*,*) 'Hodnota ucelove funkce',(b+d)/2
        end