C Rutina 070
C-----------------------------------------------------------RESUELVE1---
c
c
SUBROUTINE RESUELVE1(Aij,Fi,Xj,N)
C
C The subroutine pivo solves the system of equations applying a
C standard elimination Gauss Method with pivoting for columns.
C
C Aij*Xj=Fi
C
IMPLICIT NONE
INCLUDE '_param.for'
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C VARIABLES EXTERNAS
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C A(,),F(),X() : Matriz del sistema,termino independiente e incognitas
REAL*8 Aij(N_MAX_INC,N_MAX_INC),Fi(N_MAX_INC),Xj(N_MAX_INC)
C N : Numero de filas
INTEGER N
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C VARIABLES INTERNAS
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C F,C,FF : Contadores
INTEGER f,c,ff
C PMX: Posicion de pivote maximo
INTEGER fp,fc
C MX : Pivote maximo
REAL*8 MX
C IPIVO(): Pivotes
INTEGER fPIVO(N_MAX_INC)
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C VALORES INICIALES
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C Bucle que recorre las ecuaciones
C
DO f= 1 , n
FPIVO(f)=f
END DO
C
WRITE(*,*)
WRITE(*,*)
C
DO f = 1 , n
C
fc=f
fp=FPIVO(f)
mx=Aij(fp,f)
C
C Calculo del pivote maximo
C
DO c = f+1 , n
C
IF(DABS(Aij(FPIVO(c),f)).GT.DABS(mx)) THEN
fc=c
fp=FPIVO(c)
mx=Aij(fp,f)
END IF
END DO
C
FPIVO(fc)=FPIVO(f)
FPIVO(f)=fp
C
IF(DABS(mx).LT.TOL) THEN
C Matriz singular
WRITE(F_W,13201) mx , n-f+1
WRITE (*,13201) mx , n-f+1
oops STOP
ELSE
C
WRITE(*,1) f,n,mx
C
DO c = f+1 , n
Aij(fp,c)=Aij(fp,c)/Aij(fp,f)
END DO
Fi(fp)=Fi(fp)/Aij(fp,f)
Aij(fp,f)=1.d0
C
DO ff = 1 , n
IF(ff.ne.fp) THEN
DO c = f+1 , n
Aij(ff,c)=Aij(ff,c) - Aij(ff,f) * Aij(fp,c)
END DO
Fi(ff)=Fi(ff)-Aij(ff,f)*Fi(fp)
Aij(ff,f)=0.d0
END IF
END DO
END IF
C
END DO
C
DO f = 1 , n
Xj(f)=Fi(FPIVO(f))
END DO
C
C FIN DE LA RUTINA
C
RETURN
C
C FORMATOS DE ESCRITURA
C
13201 FORMAT(/,2x,'ERROR 13201 - RESUELVE1 - Matriz singular (',e8.2,
@ ',',i4,').')
1 FORMAT('+',2x,'RESUELVE1-Pivotando: ',i6,' - ',i6,' - ',e8.2)
C
END
C
e-REdING. Biblioteca de la Escuela Superior de Ingenieros de Sevilla.
