C Rutina 070
C-----------------------------------------------------------RESUELVE3---
C
SUBROUTINE RESUELVE3(Aij,Fi,NF,NC)
C
C The subroutine RESUELVE3 applies a standard elimination Gauss Method
C with pivoting for columns and rows
C
IMPLICIT NONE
INCLUDE '_param.for'
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C VARIABLES EXTERNAS
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C Aij(,),Fi() : Matriz del sistema y termino independiente
REAL*8 Aij(N_MAX_INC,N_MAX_INC),Fi(N_MAX_INC)
C NF,NC : Numero de filas y columnas
INTEGER NF,NC
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C VARIABLES INTERNAS
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C N,F,C,FF,CC,FP,CP : Contadores
INTEGER N,F,C,FF,CC,FP,CP
C MX : Pivote maximo
REAL*8 MX
C PIVO : Pivotes
REAL*8 PIVO
C FPIVO,CPIVO : Posicion de los pivotes
INTEGER FPIVO(N_MAX_INC),CPIVO(N_MAX_INC)
C
CCCCCCCCCCCCCCCCCCCCCCCCCC
C VALORES INICIALES
CCCCCCCCCCCCCCCCCCCCCCCCCC
C
DO n= 1 , nf
FPIVO(n)=n
END DO
C
DO n= 1 , nc
CPIVO(n)=n
END DO
C
CCCCCCCCCCCCCCC
C RUTINA
CCCCCCCCCCCCCCC
C
C Bucle que recorre las filas de la matriz
C
WRITE(*,*)
WRITE(*,*)
C
DO n = 1 , nf
C
mx=0.d0
C
C Calculo del pivote maximo
C
DO ff = n , nf
f=FPIVO(ff)
DO cc= n ,nc
c=CPIVO(cc)
pivo=Aij(f,c)
IF(DABS(pivo).GT.DABS(mx))THEN
mx=pivo
fp=f
cp=c
END IF
END DO
END DO
C
IF(DABS(mx).LT.TOL) THEN
C Matriz singular
WRITE(F_W,13401) mx , nf-n+1
WRITE (*,13401) mx , nf-n+1
oops STOP
END IF
C
WRITE(*,1) n,nf,mx
C
C Actualiza la posicion de los pivotes
C
ff=n
DO WHILE(ff.LT.nf)
ff=ff+1
f=FPIVO(ff)
IF(f.EQ.fp)THEN
FPIVO(ff)=FPIVO(n)
ff=nf
END IF
END DO
FPIVO(n)=fp
cc=n
DO WHILE(cc.LT.nc)
cc=cc+1
c=CPIVO(cc)
IF(c.EQ.cp)THEN
CPIVO(cc)=CPIVO(n)
cc=nc
END IF
END DO
CPIVO(n)=cp
C
C Divide la fila de pivote por el pivote
C
DO cc = n+1 , nc
c=CPIVO(cc)
IF(c.NE.cp)THEN
Aij(fp,c)=Aij(fp,c)/Aij(fp,cp)
END IF
END DO
Fi(fp)=Fi(fp)/Aij(fp,cp)
Aij(fp,cp)=1.d0
C
C Pivota las demas filas
C
DO ff = 1 , nf
f=FPIVO(ff)
IF(f.ne.fp) THEN
DO cc = n+1 , nc
c=CPIVO(cc)
IF(c.NE.cp)THEN
Aij(f,c)=Aij(f,c) - Aij(f,cp) * Aij(fp,c)
END IF
END DO
Fi(f)=Fi(f)-Aij(f,cp)*Fi(fp)
Aij(f,cp)=0.d0
END IF
END DO
C
C Fin bucle que recorre las filas de la matriz
C
END DO
C
C FIN DE LA RUTINA
C
RETURN
C
C FORMATOS DE ESCRITURA
C
13401 FORMAT(/,2x,'ERROR 13401 - RESUELVE3 - Matriz singular (',e8.2,
@ ',',i4,').')
1 FORMAT('+',2x,'RESUELVE3-Pivotando: ',i6,' - ',i6,' - ',e8.2)
C
END
C
e-REdING. Biblioteca de la Escuela Superior de Ingenieros de Sevilla.
