¡Descarga Programas Fortran - Apuntes - Análisis Numérico y más Apuntes en PDF de Métodos Matemáticos para Análisis Numérico y Optimización solo en Docsity!
METODO DE GAUSS JORDAN
program Gauss_Jordan
IMPLICIT NONE
integer N,i,j,k, p
real(8) A(10,11), X(10), SUM, r(10), nueva(10,10),b(10)
real Z(10,11)
print *, 'Ingrese N'
read *,N
Call ingreso_a (n,a)
z=
do k=1,n
Call ingreso_b (n,a)
Call separacion (n,a,nueva,b)
Call triangulacion (n,a)
Call solucion (n,a,x,sum)
z(k,1:n)=x
call residuo (n,nueva,b,x,r)
call determinante (n,a)
enddo
Do i=1,n
print *,z(i,1),' ',z(i,2),' ',Z(i,3)
enddo
CONTAINS
Subroutine ingreso_a (n,a)
integer n,i,j
real(8) A(10,11)
print *,'Ingrese la matriz A'
DO i=1,n
DO j=1,n
print 1,'A(',i,',',j,')='
1 FORMAT (A3,I2,A1,I2,A3)
read *,A(i,j)
END DO
END DO
end subroutine ingreso_a
Subroutine ingreso_b (n,a)
integer n,i
real(8) a(10,11)
print *,'Ingrese el vector B'
DO i=1,N
print 2 ,'B(',i,')='
2 FORMAT (A3,I2,A2)
read *,A(i,N+1)
END DO
end subroutine ingreso_b
Subroutine separacion (n,a,nueva,b)
integer i,j,n
real(8) a(10,11), b(10), nueva(10,10)
Do i=1,n
do j=1,n
nueva(i,j)=a(i,j)
b(i)=a(i,n+1)
enddo
enddo
end subroutine separacion
Subroutine pivoteo (n,a,p)
integer n,fil,i,j,p,maxi
real(8) a(10,11), aux(11)
maxi=abs(a(p,p))
fil=p
Do i=p+1,n
IF (abs(a(i,p))>abs(a(p,p))) THEN
maxi=abs(a(i,p))
fil=i
endif
enddo
Do j=1,n+
aux(j)=a(fil,j)
a(fil,j)=a(p,j)
a(p,j)=aux(j)
enddo
end subroutine pivoteo
subroutine triangulacion (n,a)
integer n,p,i,j
real(8) a(10,11)
DO p=1,N-
Call pivoteo (n,a,p)
DO i=p+1,N
DO j=p+1,N+
end subroutine residuo
subroutine determinante(n,a)
integer n,i,j
real(8) a(10,11),det
det=
do i=1,n
do j=1,n
if (i==j) then
det=det*a(i,j)
end if
enddo
enddo
print*,'El determinante vale ',det
end subroutine determinante
END PROGRAM Gauss_Jordan
ECUACION CUADRATICA
Program una_ecuacion
real(8) xi,yi,xa,ya,h,xf integer i,sel,n
Call Ingreso(xi,yi,xf,n,h)
print,'*****(ACA VA LO QUE HACE)**********' Do While (sel<>6) print,'Seleccionar el método' print,'1-Euler Simple' print,'2-Euler Modificado' print,'3-Runge Kutta de Cuarto Orden' print,'4-Runge Kutta Fehlberg' print,'5-Ingresar otros datos' print,'6-Salir' read*,sel Select Case (sel) Case (1) Call eulersimple(xi,yi,xf,h) Case (2) Call eulermodificado(xi,yi,xf,h) Case (3) Call rk(xi,yi,xf,h) Case (4) Call rkf(xi,yi,xf,h) Case (5) Call Ingreso(xi,yi,xf,n,h) Case (6)
print,'Hasta Luego' Case Default print,'Ingresar una opción válida' EndSelect EndDo
Contains
Subroutine Ingreso (xi,yi,xf,n,h) real(8), intent(inout) :: xi,yi,h,xf integer, intent(inout) :: n integer sel print,'Ingresar el Punto (xo,f(xo))' read,xi,yi print,'Ingresar Valor Final de x' read,xf print,'Seleccionar:' print,'1-Ingresar el Incremento' print,'** o ' print,'2-Ingresar la Cantidad de Pasos' read,sel SelectCase (sel) Case (1) print,'Incremento?' read,h n=(xf-xi)/h Case (2) print,'Pasos?' read,n h=(xf-xi)/n Case Default print,'Ingresar 1 ó 2' EndSelect EndSubroutine Ingreso
Subroutine eulersimple(xi,yi,xf,h) real(8) xi,yi,xa,ya,h,xf ya=yi Do xa=xi,xf,h write(,fmt='(F10.4,A1,F10.4)') xa,' ',ya ya=ya+hypr(xa,ya) EndDo Endsubroutine eulersimple
Subroutine eulermodificado(xi,yi,xf,h) real(8) xi,yi,xa,ya,h,xf ya=yi Do xa=xi,xf,h write(,fmt='(F10.4,A1,F10.4)') xa,' ',ya ya= ya+(h/2)(ypr(xa,ya)+ypr(xa+h,ya+h*ypr(xa,ya))) EndDo EndSubroutine eulermodificado
Subroutine rk(xi,yi,xf,h) real(8) xi,yi,xa,ya,h,xf,k1,k2,k3,k ya=yi Do xa=xi,xf,h write(,fmt='(F10.5,A1,F10.5)') xa,' ',ya k1 = hypr(xa,ya) k2 = h*ypr((xa+(h/2.)),(ya+(k1/2.)))
ALLOCATE(v_aprox(0:cant_ec))
CALL ingDatos(v, h, cant_iter, cant_ec)
DO iter = 0, cant_iter WRITE(,'(I4)') iter DO i = 0, cant_ec WRITE (,'(F10.6)') v(i) ENDDO WRITE (,) ''
v_aprox = v + hy_prima(v, cant_ec) v = v + h(y_prima(v, cant_ec)+y_prima(v_aprox, cant_ec))/2.
END DO
CONTAINS
! Definición de la función derivada FUNCTION y_prima(v, cant_ec) INTEGER cant_ec REAL(8), DIMENSION(0:cant_ec) :: v, y_prima
y_prima(0) = 1. y_prima(1) = 2*v(1) y_prima(2) = 2.
END FUNCTION y_prima
SUBROUTINE ingDatos(v, h, cant_iter, cant_ec) INTEGER i, cant_ec REAL(8), DIMENSION(0:cant_ec), INTENT(INOUT) :: v REAL(8) h INTEGER, INTENT(INOUT) :: cant_iter
DO i = 0, cant_ec WRITE (*, '(A15, I2, A4)') 'Ingrese v_inic(',i,') : ' READ *,v(i) ENDDO
WRITE (*, '(A)') 'Ingrese h : ' READ *,h
WRITE (*, '(A)') 'Ingrese cantidad de iteraciones : ' READ *,cant_iter
END SUBROUTINE ingDatos
END PROGRAM euler_n
GAUSS SIMPLE
program Gauss IMPLICIT NONE integer N,i,j, p real(8) A(10,11), X(10), SUM, r(10), nueva(10,10),b(10)
print *, 'Ingrese N' read *,N
Call ingreso_a (n,a)
Call ingreso_b (n,a)
Call separacion (n,a,nueva,b)
Call triangulacion (n,a)
Call solucion (n,a,x,sum)
call residuo (n,nueva,b,x,r)
call determinante (n,a)
CONTAINS
Subroutine ingreso_a (n,a) integer n,i,j real(8) A(10,11) print *,'Ingrese la matriz A'
DO i=1,n DO j=1,n print 1,'A(',i,',',j,')=' 1 FORMAT (A3,I2,A1,I2,A3) read *,A(i,j) END DO END DO end subroutine ingreso_a
Subroutine ingreso_b (n,a) integer n,i real(8) a(10,11) print *,'Ingrese el vector B' DO i=1,N print 2 ,'B(',i,')=' 2 FORMAT (A3,I2,A2) read *,A(i,N+1) END DO end subroutine ingreso_b
Subroutine separacion (n,a,nueva,b) integer i,j,n real(8) a(10,11), b(10), nueva(10,10) Do i=1,n do j=1,n nueva(i,j)=a(i,j) b(i)=a(i,n+1) enddo enddo
mome=Matmul(nueva,x) r=mome-b print *,'El vector residuo es =' DO i=1,n print 11,'r(',i,')=',r(i) 11 FORMAT (A2,I2,A2,F8.4) END DO end subroutine residuo
subroutine determinante(n,a) integer n,i,j real(8) a(10,11),det det= do i=1,n do j=1,n if (i==j) then det=deta(i,j) end if enddo enddo print,'El determinante vale ',det end subroutine determinante
END PROGRAM Gauss
RUNGE KUTTA 4
Program Runge_Kutta_4toOrden
USE MSFLIB! Para poder usar limpieza de pantalla Implicit None Interface Double precision Function fxy(xx,yy) Double precision , intent(in):: xx,yy End function Double precision Function fx(xx) Double precision , intent(in):: xx End function End Interface
Double precision Listaxy(3000,3),listaReal(3000,2) Double precision x0,y0,X,Xn,Y,h,hi,n,yaux,yreal,hmin Integer qq,t,Iter,k,opcion !,repet Character50 nombre_arch Character1 veriter 10 Format(I5,f15.8,2f20.13,1f15.7) !,f12.10) opcion= x0= y0= xn=1. n= hmin=0. veriter ='S' !*** INICIO SENTENCIAS PROGRAMA EJECUTABLE *** Call Valorinicial(x0,y0,Xn,veriter) DO WHILE (opcion .NE.0) ! Guardo valores iniciales en el vector
t= listaxy(t,1)=x listaxy(t,2)=y listaReal(t,1)=x listaReal(t,2)=fx(x0) !hi=(Xn-x0)/n !h=hi x=x y=y
Call MENU1(opcion)
SELECT CASE (OPCION) CASE (1) Print * ,' Ingrese el h' Read *,h listaxy(t,3)=h n=int((xn-x0)/h+.5) print *,' t x y Caculado Y Real h' Print 10,t,x,y,listareal(1,2) Do While (x<=Xn) t=t+ yaux=y Call RK4(fxy,x,yaux,h) yreal=fx(x+h) if ((veriter .EQ."s").OR.(veriter .EQ."S")) then Print 10,t,x+h,yaux,yreal,h end if x=x+h y=yaux listaxy(t,1)=x listaxy(t,2)=y listaxy(t,3)=h listareal(t,1)=x listareal(t,2)=YREAL End Do Iter=t Print * ,'********** Fin del proceso ************' Print *,'0 para seguir iter =',iter read *,qq CALL CLEARSCREEN($GCLEARSCREEN)
t=1;k= Print * ,'Desea ver los valores generados S/N' Read ,veriter IF ((veriter .EQ."s").OR.(veriter .EQ."S")) then Print ,' t x y Caculado Y Real h' Print ,' Valores iniciales y valores en el vector ***' Print 10,t,listaxy(t,1),listaxy(t,2),listaREAL(t,2),LISTAXY(t,3) Print *,'' Do While (t<iter) do while ((k<26).and. (t<iter)) t=t+ k=k+ Print 10,t,listaxy(t,1),listaxy(t,2),listaREAL(t,2),LISTAXY(t,3)
print *,' Ingrese opcion' Read *,opcionx CALL CLEARSCREEN($GCLEARSCREEN) End subroutine Menu
Subroutine Valorinicial(x0,y0,Xn,veriter) real(8),intent(inout)::x0,y0,Xn character*1,intent(inout)::veriter Print *,'Ingrese el valor de x0'; Read *,x Print * ,'Ingrese el valor de y0' Read *,y Print * ,'Ingrese el valor de Xn' Read *,Xn Print * ,'Desea ver las iteraciones S/N' Read *,veriter
End subroutine Valorinicial
Subroutine RK4(g,xg,yg,hg) real(8) g real(8),intent(in) :: hg,xg real(8),intent(inout)::yg real(8) k1,k2,k3,k k1=hgg(xg,yg) k2=hgg(xg+hg/2.0,yg+k1/2.0) k3=hgg(xg+hg/2.0,yg+k2/2.0) k4=hgg(xg+hg ,yg+k3)
Yg=yg+(k1+2k2+2k3+k4)/
End Subroutine RK
End Program Runge_Kutta_4toOrden !********************************************* !=============================================
! FUNCIONES EXTERNAS
Double precision Function fxy(xx,yy) Double precision,intent(in):: xx,yy fxy=xxyy*(1.0/3.0) !1/
!fxy=x+y End function fxy
Double precision Function fx(xx) Double precision,intent(in):: xx fx=((xx2+2)/3)1. !fxy=x+y End function fx
! Fin listado
RUNGE KUTTA
Program rk_ implicit none real(8) x_i,y_i,x_a,y_a,h,x_f,k1,k2,k3,k
integer n,i
Call ingreso(x_i,y_i,x_f,n,h)
call rk4(x_i,y_i,x_f,h)
Contains
Subroutine ingreso (x_i,y_i,x_f,n,h) real(8), intent(inout) :: x_i,y_i,h,x_f integer, intent(inout) :: n print,'ingrese las coordenadas conocidas' read,x_i,y_i print,'ingrese el valor final de x' read,x_f print,'ingrese el valor del incremento' read,h n=(x_f-X_i)/h end subroutine ingreso
subroutine rk4(x_i,y_i,x_f,h) real(8) x_i,y_i,x_a,y_a,h,x_f,k1,k2,k3,k
y_a=y_i Do x_a=x_i,x_f,h write(,fmt='(F10.5,A1,F10.5)') x_a,' ',y_a k1= hy_prima(x_a,y_a) k2= hy_prima((x_a+(h/2.)),(y_a+(k1/2.))) k3= hy_prima((x_a+(h/2.)),(y_a+(k2/2.))) k4= hy_prima((x_a+h),(y_a+k3)) y_a= y_a + (k1+2k2+2*k3+k4)/6. end do
end subroutine rk
real(8) function y_prima(x,y) real(8) x,y y_prima= end function y_prima
end program rk_
EULER MODIFICADO
Program euler_modificado implicit none real(8) x_i,y_i,x_a,y_a,h,x_f integer n,i
Call ingreso(x_i,y_i,x_f,n,h) y_a=y_i
Do x_a=x_i,x_f,h write(,fmt='(F10.4,A1,F10.4)') x_a,' ',y_a y_a= y_a+(h/2)(y_prima(x_a,y_a)+y_prima(x_a+h,y_a+h*y_prima(x_a,y_a))) enddo
END DO
end subroutine ingreso_a
Subroutine ingreso_b (n,a) integer n,i real(8) a(10,11) print *,'Ingrese el vector B' DO i=1,N print 2 ,'B(',i,')=' 2 FORMAT (A3,I2,A2) read *,A(i,N+1) END DO end subroutine ingreso_b
Subroutine separacion (n,a,nueva,b) integer i,j,n real(8) a(10,11), b(10), nueva(10,10) Do i=1,n do j=1,n nueva(i,j)=a(i,j) b(i)=a(i,n+1) enddo enddo end subroutine separacion
Subroutine pivoteo (n,a,p) integer n,fil,i,j,p,maxi real(8) a(10,11), aux(11)
maxi=abs(a(p,p)) fil=p Do i=p+1,n IF (abs(a(i,p))>abs(a(p,p))) THEN maxi=abs(a(i,p)) fil=i endif enddo Do j=1,n+ aux(j)=a(fil,j) a(fil,j)=a(p,j) a(p,j)=aux(j) enddo end subroutine pivoteo
subroutine triangulacion (n,a) integer n,p,i,j real(8) a(10,11) DO p=1,N- Call pivoteo (n,a,p) DO i=p+1,N DO j=p+1,N+ if (p <> i) then A(i,j)= A(i,j)-A(i,p)*A(p,j)/A(p,p) endif END DO END DO END DO DO p=n, Call pivoteo (n,a,p) DO i=p-1,1,-
DO j=p,1,- if (p <> i) then A(i,j)= A(i,j)-A(i,p)*A(p,j)/A(p,p) endif END DO END DO END DO end subroutine triangulacion
subroutine solucion(n,a,x,sum) integer n,i,j
real(8) a(10,11), x(10), sum
x(N)=A(N,N+1)/a(n,n)
DO i=N-1,1,- SUM=0. DO j=i+1,N SUM=SUM+A(i,j)*x(j) END DO x(i)=(A(i,N+1)-SUM)/a(i,i) END DO print *,'La solucion es =' DO i=1,n print 9,'X(',i,')=',X(i) 9 FORMAT (A2,I2,A2,F16.4) END DO end subroutine solucion
subroutine residuo (n,nueva,b,x,r) integer n,i,j real(8) a(10,11), x(10), r(10),nueva (10,10),b(10), mome(10)
mome=Matmul(nueva,x) r=mome-b print *,'El vector residuo es =' DO i=1,n print 11,'r(',i,')=',r(i) 11 FORMAT (A2,I2,A2,F8.4) END DO end subroutine residuo
subroutine determinante(n,a) integer n,i,j real(8) a(10,11),det det= do i=1,n do j=1,n if (i==j) then det=deta(i,j) end if enddo enddo print,'El determinante vale ',det end subroutine determinante
END PROGRAM Gauss_Jordan
Hasta acá primer parcial
real(8) x(:)
PRINT *,'Ingrese valores para solucion inicial:' DO I=1,N PRINT 2,'X(',I,')=' 2 FORMAT(A2,I2,A2) READ *,X(I) END DO
End subroutine solucion_inicial
! Sistema de ecuaciones no lineales
Subroutine FUN(N,X,F) integer N real(8) X(:),F(:)
F(1)= 4 - X(1)2- X(2) F(2)= 1 - exp(X(1)) - X(2)
END SUBROUTINE
! Jacobiano
Subroutine Jacobiano(N,X,JACO)
Integer N Real(8) X(:), JACO(:,:)
JACO(1,1)= -2*X(1)
JACO(1,2)= -2*X(2)
JACO(2,1)= - EXP(X(1))
JACO(2,2)= -
End Subroutine Jacobiano
SUBROUTINE MAT_VEC(N,MAT,VEC,V)
REAL(8), INTENT(IN)::MAT (:,:)
REAL(8), INTENT(IN)::VEC (:)
INTEGER, INTENT(IN)::N
REAL(8), INTENT(OUT)::V(:)
integer k,j
DO K=1,N
V(K)=
DO I=1,N
V(K)=V(K)+MAT(K,I)*VEC(I)
END Do END DO
END SUBROUTINE MAT_VEC
SUBROUTINE RESTA_VEC(N,VEC,VEC2)
REAL(8),INTENT(INOUT)::VEC(:)
REAL(8),INTENT(IN)::VEC2(:)
INTEGER , INTENT(IN)::N
integer k
DO k=1,N VEC(k)=VEC(k)-VEC2(k) END DO
END SUBROUTINE RESTA_VEC
End Program Punto_Fijo_Sistema
Biseccion, Punto Fijo y Newton para una ecuacion
Program una_ecuacion
implicit none
integer sel real(8) a,b,errormax,m
Call ingreso(a,b,errormax)
print,'******* ACA VA LO QUE HACE *******' Do While (sel<>5) print,'Seleccionar el método' print,'1-Biseccion' print,'2-Punto fijo (sustitucion regresiva)' print,'3-Newton' print,'4-Ingresar otros datos' print,'5-Salir' read,sel Select Case (sel) Case (1) Call biseccion(a,b,errormax,m) Case (2) Call punto_fijo(a,b,errormax) Case (3) Call Newton(a,b,errormax) Case (4) Call Ingreso(a,b,errormax) Case (5) print,'Hasta Luego' Case Default print,'Ingresar una opción valida' EndSelect EndDo
CONTAINS
