C Rutina 070
C-----------------------------------------------------------RESUELVE2---
C
SUBROUTINE RESUELVE2(Aij,Fi,Xj,NF,Fo)
C
C LA SUBRUTINA RESUELVE2 CALCULA LA SOLUCION DE UN SISTEMA DE ECUACIONES
C EN EL QUE LAS PRIMERAS Fo FILAS YA ESTAN PIVOTADAS (CALCULANDO EL PIVOTE MAXIMO
C EN CADA PASO)
C
C Aij*Xj=Fi
C
IMPLICIT NONE
INCLUDE '_param.for'
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C VARIABLES EXTERNAS
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C Aij(,),Fi(),Xj() : 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 NF : Numero de filas
INTEGER NF
C Fo : Numero de filas ya pivotadas
INTEGER Fo
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C VARIABLES INTERNAS
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C F,C,FF,CC,FP,CP,N : Contadores
INTEGER f,c,ff,cc,fp,cp,n
C FPIVO,CPIVO : Posicion de los pivotes
INTEGER CPIVO(N_MAX_INC),FPIVO(N_MAX_INC)
C PIVO : Pivote
REAL*8 PIVO
C MX : Pivote maximo
REAL*8 MX
C
CCCCCCCCCCCCCCCCCCCCCCCCCC
C VALORES INICIALES
CCCCCCCCCCCCCCCCCCCCCCCCCC
C
DO n=1,nf
FPIVO(n)=n
CPIVO(n)=n
END DO
C
CCCCCCCCCCCCCCC
C RUTINA
CCCCCCCCCCCCCCC
C
C Bucle que recorre las filas ya pivotadas
C
WRITE(*,*)
WRITE(*,*)
C
DO n=1,Fo
C
c=0
DO WHILE(c.LT.nf)
c=c+1
C
C Localizacion de los pivotes
C
IF(Aij(n,c).EQ.1.d0)THEN
f=0
DO WHILE(f.LT.Fo)
f=f+1
IF(f.NE.n)THEN
IF(Aij(f,c).NE.0.d0)THEN
f=Fo+1
END IF
END IF
END DO
IF(f.EQ.Fo)THEN
cc=1
DO WHILE (cc.LT.nf)
cc=cc+1
IF(CPIVO(cc).EQ.c)THEN
CPIVO(cc)=CPIVO(n)
cc=nf
END IF
END DO
CPIVO(n)=c
c=nf+1
END IF
END IF
END DO
C
IF(c.EQ.nf)THEN
WRITE(F_W,13300) 1
WRITE (*,13300) 1
STOP
END IF
C
C Fin bucle que recorre las filas ya pivotadas
C
END DO
C
C Bucle que recorre las columnas pivotadas parcialmente
C
DO n=1,Fo
C
WRITE(*,1) n,nf
C
fp=FPIVO(n)
cp=CPIVO(n)
C
C Pivotaje de la parte de la columna no pivotada
C
DO ff=Fo+1,nf
f=FPIVO(ff)
C
DO cc=1,nf
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
C
C Fin bucle que recorre las filas no pivotadas
C
END DO
C
C Fin bucle que recorre las columnas pivotadas parcialmente
C
END DO
C
C Bucle que recorre las filas no pivotadas
C
DO n=Fo+1 , nf
C
WRITE(*,1) n,nf,mx
C
C Calculo del pivote maximo
C
mx=0.d0
DO ff= n , nf
f=FPIVO(ff)
DO cc= n , nf
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,13301) mx , nf-n+1
WRITE (*,13301) mx , nf-n+1
oops STOP
END IF
C
C Actualizacion de 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.nf)
cc=cc+1
c=CPIVO(cc)
IF(c.EQ.cp)THEN
CPIVO(cc)=CPIVO(n)
cc=nf
END IF
END DO
CPIVO(n)=cp
C
C Pivotaje de las filas restantes
C
DO cc = n+1 , nf
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
DO ff = 1 , nf
f=FPIVO(ff)
IF(f.ne.fp) THEN
DO cc = n+1 , nf
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 no pivotadas
C
END DO
C
DO n=1,nf
Xj(CPIVO(n))=Fi(FPIVO(n))
END DO
C
C FIN DE LA RUTINA
C
RETURN
C
C FORMATOS DE ESCRITURA
C
13300 FORMAT(/,2x,'ERROR 13300 - RESUELVE2 - Error Programa (#',i2,
@ '#).')
13301 FORMAT(/,2x,'ERROR 13301 - RESUELVE2 - Matriz singular (',e8.2,
@ ',',i4,').',/,/)
1 FORMAT('+',2x,'RESUELVE2-Pivotando: ',i6,' - ',i6,' - ',e8.2)
C
END
C
e-REdING. Biblioteca de la Escuela Superior de Ingenieros de Sevilla.
