1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
|
SUBROUTINE ANRS01(R,IR,M,B,X,IND,IO)
C
C***********************************************************************
C *
C *
C ORIGEN: Eduardo Casas Renteria *
C Cecilia Pola Mendez *
C *
C Departamento de Matematicas,Estadistica y Computacion *
C ----------------------------------------------------- *
C UNIVERSIDAD DE CANTABRIA *
C ------------------------ *
C FEBRERO 1987 *
C *
C***********************************************************************
C
C OBJETIVO:
C Esta subrutina resuelve un sistema de ecuaciones lineales en el
C que la matriz de coeficientes es triangular.
C
C LISTA DE LLAMADA:
C DE ENTRADA:
C
C R Matriz de dimension (IR,M),triangular superior.Contiene
C en sus M primeras filas a la matriz de coeficientes del
C sistema.La parte subdiagonal de R no es utilizada.
C
C IR Primera dimension de la matriz R. IR >= N.
C
C M Numero de filas y columnas de la matriz de coeficientes.
C
C B Vector M-dimensional.Guarda los terminos independientes
C del sistema.
C
C IND Indica el tipo de sistema a resolver,con los valores:
C 1 : Se resuelve R'x=b
C 2 : Se resuelve Rx=b
C
C IO Numero de canal de salida de resultados.
C
C DE SALIDA:
C
C X Vector m-dimensional en el que se recoge la solucion
C del sistema.
C
C Esta subrutina trabaja en doble precision via una sentencia
C "implicit":
C Implicit double precision (a-h,o-z)
C
C SUBPROGRAMAS AUXILIARES: ddot,dlamch
C FUNCIONES FORTRAN INTRINSECAS: abs,mod
C
C
implicit double precision(a-h,o-z)
dimension r(ir,*),b(*),x(*)
CXC
CXC Se comprueba si los valores de las variables son correctos
CXC
CX if(m.lt.1 .or. ir.lt.1 .or. m.gt.ir .or. ind.lt.1 .or. ind.gt.2)
CX & then
CX write(io,1000) 'INCORRECT LIST OF CALLING IN ANRS01.'
CX stop
CX end if
CXC
CXC Se calcula un parametro para detectar la posible singularidad de
CXC la matriz de coeficientes
CXC
CX epsmch=dlamch('p')**0.9
C
C Se comienza la resolucion del sistema segun sea el indicador
C
if(ind.eq.1) then
j=1
else
j=m
end if
CX if(abs(r(j,j)).lt.epsmch) then
CX write(io,1000) 'SINGULAR MATRIX IN ANRS01.'
CX stop
CX end if
x(j)=b(j)/r(j,j)
if(m.eq.1) return
do 10 i=2,m
i1=i-1
if(ind.eq.1) then
j=i
j1=1
j2=i
j3=1
k=1
else
j=m-i1
j1=j
j2=j+1
j3=j2
k=ir
end if
CX if(abs(r(j,j)).lt.epsmch) then
CX write(io,1000) 'SINGULAR MATRIX IN ANRS01.'
CX stop
CX end if
x(j)=(b(j)-ddot(i1,r(j1,j2),k,x(j3),1))/r(j,j)
10 continue
1000 format(10x,A)
end
|
