Esercizi in Fortran - Progettoatena.It

NOTAZIONI ..................................................................................................................................................... 2
SOMMA DI 2 MATRICI QUADRATE ........................................................................................................... 2
PRODOTTO MATRICE (QUADRATA) PER VETTORE ............................................................................. 2
PRODOTTO DI 2 MATRICI QUALSIASI C=A*B ........................................................................................ 2
PRODOTTO di una MATRICE QUALSIASI (mxn) per un VETTORE......................................................... 3
TRASPOSTA di una MATRICE ...................................................................................................................... 3
CONTROLLO DI SIMMETRIA DI UNA MATRICE (QUADRATA)........................................................... 3
CONTROLLO DI MATRICE STRETTAMENTE DIAGONALE DOMINANTE PER RIGHE ................... 4
1°VERSIONE: .............................................................................................................................................. 4
2°VERSIONE: .............................................................................................................................................. 4
METODO DELLE POTENZE per il CALCOLO dell'AUTOVALORE MAX IN MODULO........................ 5
di una MATRICE (SIMMETRICA) A.............................................................................................................. 5
CONTROLLO DI MATRICE con a(i,i) > 0 e a(i,j) 0 e a(i,j)

NOTAZIONI
Nel Fortran tutte le costanti e variabili che iniziano per:
sono implicitamente dichiarate di tipo integer
SOMMA DI 2 MATRICI QUADRATE
subroutine sommamatrici(a,b,c,ld,n)
real a(ld,*), b(ld,*), c(ld,*)
do i = 1, n
do j = 1, n
c(i,j) = a(i,j) + b(i,j)
enddo
enddo
return
end
i j k l m n
PRODOTTO MATRICE (QUADRATA) PER VETTORE
subroutine matvet(a,v,b,n,ld)
real a(ld,*), v(*), b(*)
do i=1,n
b(i)=0
do j=1,n
b(i)=b(i)+a(i,j)*v(j)
enddo
enddo
return
end
PRODOTTO DI 2 MATRICI QUALSIASI C=A*B
subroutine matqmatq(a,b,c,ma,n,nb,ld)
ma = righe di a,c n = colonne di a e righe di b, nb = colonne di b,c
real a(ld,*), b(ld,*), c(ld,*)
do i=1,ma
do j=1,nb
c(i,j)=0.0
do k=1,n
c(i,j)=c(i,j)+a(i,k)*b(k,j)
enddo
enddo
enddo
return
end
2

PRODOTTO di una MATRICE QUALSIASI (mxn) per un VETTORE
subroutine matqvet (a,v,b,m,n,ld)
m=righe di a, n=colonne di a e righe di v
real a(ld,*), v(*), b(*)
do i = 1,m
b(i) = 0.0
do k = 1,n
b(i) = b(i) + a(i,k) * v(k)
enddo
enddo
return
end
TRASPOSTA di una MATRICE
subroutine trasposta(a,at,m,n,ld)
real a(ld,*), at(ld,*)
m=numero righe n=numero colonne (di A)
do i=1,n
do j=1,m
at(i,j)=a(j,i)
enddo
enddo
CONTROLLO DI SIMMETRIA DI UNA MATRICE (QUADRATA)
subroutine simmetrica(a,n,ld,info)
real a(ld,*)
info=0
do i=1,n
do j=1,i-1
if (a(i,j).EQ.a(j,i) then
info=1
else
info=0
write(*,*)'Matrice non simmetrica'
stop
endif
enddo
enddo
return
end
3

CONTROLLO DI MATRICE STRETTAMENTE DIAGONALE DOMINANTE PER
RIGHE
1°VERSIONE:
subroutine ddr(a,n,ld,info)
real a(ld,*)
info=0
s=0
do i=1,n
do j=i,i-1
s=s+abs(a(i,j))
enddo
do j=i+1,n
s=s+abs(a(i,j))
enddo
if(abs(a(i,i)).GT.s) then
info=1
else
info=0
write(*,*)'Matrice non strett. diag. dom. per righe'
stop
endif
return
end
2°VERSIONE:
subroutine ddr(a,n,ld,info)
real a(ld,*)
info=0
s=0
do i=1,n
do j=i,n
if(i.NE.j) then
s=s+abs(a(i,j))
endif
enddo
if(abs(a(i,i)).GT.s) then
info=1
else
info=0
write(*,*)'Matrice non strett. diag. dom. per righe'
stop
endif
return
end
4

METODO DELLE POTENZE per il CALCOLO dell'AUTOVALORE MAX IN MODULO
di una MATRICE (SIMMETRICA) A
program metodopotenze
parameter(ld=20,kmax=100)
real a(ld,ld), v0=(ld), u(ld), gamma(kmax), beta(kmax)
write(*,*)'ordine di A'
read(*,*), n
write(*,*)'elementi di A'
do i=1,n
read(*,*)(a(i,j), j=1,n)
enddo
info=0
call simmetrica(a,n,ld,info)
if(info.EQ.1) then
write(*,*)'OK matrice simmetrica'
endif
call ddr(a,n,ld,info)
if(info.EQ.1) then
write(*,*)'OK matrice strett. diag. dom. per righe'
endif
write(*,*)'Tolleranza e iterato iniziale con norma=1'
read epsilon, (v0(i), i=1,n)
do k=1, kmax
call matvet(a,v0,u,n,ld) CALL PRODOTTO MATRICE x VETTORE
beta(k)=0.0
do i=1,n
beta(k)=beta(k)+u(i)*v0(i)
enddo
if(k.NE.1) then
if(abs(beta(k)-beta(k-1)).LE.epsilon*abs(beta(k))) then
write(*,*)'iterazione #', k
write(*,*)'autovalore max ', beta(k)
write(*,3) k, (v0(i), i=1, n)
stop
endif
endif
gamma(k)=0
do i=1,n
gamma(k)=gamma(k)+u(i)*u(i)
enddo
gamma(k)=sqrt(gamma(k))
do i=1,n
v0(i)=u(i)/gamma(k)
enddo
enddo
write(*,*)'iterazione max #', kmax
write(*,*)'autovalore max #', beta(kmax)
stop
end
5

CONTROLLO DI MATRICE con a(i,i) > 0 e a(i,j) 0 e a(i,j)

write(*,*),'matrice con el. non diag >0'
stop
endif
enddo
if((abs(a(i,j)).GT.som1).AND.(a(i,i).GT.0)) then
info=1
else
info=0
write(*,*)'matrice non strett. diag. dom. o con el diag.

eal x(ld)
ind=1
do i=2,n
if(abs(x(i)).gt.abs(x(ind))) ind=i
enddo
ormavett=abs(x(ind))
return
end
8

METODO DELLA MEDIA ARITMETICA per la RISOLUZIONE di SISTEMI LINEARI
program mediaaritmetica
parameter(ld=20,kmax=100)
real a(ld,ld), b(ld), x0(ld), xn(ld), m1(ld,ld), m2(ld,ld), m3(ld,ld),
real m4(ld,ld), c1(ld), c2(ld), y(ld), z1(ld), z2(ld)
write(*,*) 'ordine problema, ro, tolleranza'
read(*,*) n, ro, epsilon
write(*,*)'matrice per righe'
do i=1,n
read(a(i,j), j=1,n)
enddo
write(*,*)'termine noto ed interazione iniziale'
do i=1,n
read(*,*) b(i), x0(i)
enddo
Controlla che la matrice sia diag. strett. domin., che a(i,i)>0
e a(i,j)

call triinf(m1,z1,c1,n,ld)
call trisup(m3,z2,c2,n,ld)
do i=1,n
xn(i)=(z1(i)+z2(i))/2
enddo
do i=1,n
x0(i)=xn(i)-x0(i)
enddo
if(orma(x0,n,ld).LE.(epsilon*orma(xn,n,ld))) then
write(*,*)'iterazione # ',k
write(*,*)'x= ',(xn(i),i=1,n)
stop
else
write(*,*)'norma',orma(x0,n,ld),orma,xn,n,ld)
endif
do I=1,n
x0(i)=xn(i)
enddo
enddo
write(*,*)'iterazione # ',kmax
write(*,*)'x= ',(xn(i), I=1,n)
end
RISOLUZIONE DI SISTEMA LINEARE mediante l'ALGORITMO di GAUSS (SENZA
PIVOTING)
subroutine gauss(a,b,n,ld)
real a(ld,*), b(*)
do k=1,n-1
do i=k+1,n
a(i,k)=a(i,k)/a(k,k)
b(i)=b(i)-a(i,k)*b(k)
do j=k+1,n
a(i,j)=a(i,j)-a(i,k)*a(k,j)
enddo
enddo
enddo
return
end
+
subroutine risolvi(a,x,b,n,ld) (risoluzione con A triang. sup.)
real a(ld,*), x(*), b(*)
x(n)=b(n)/a(n,n)
do i=n-1,1,-1
som=0
do j=i+1,n
som=som+a(i,j)*x(j)
enddo
x(i)=(b(i)-som)/a(i,i)
10

enddo
return
end
OPPURE(in una sola subroutine)
subroutine gausstot(a,x,b,n,ld)
real a(ld,*), b(*)
Passo 1: ricava a triang. sup. e il b corrispondente
do k=1,n-1
do i=k+1,n
a(i,k)=a(i,k)/a(k,k)
b(i)=b(i)-a(i,k)*b(k)
do j=k+1,n
a(i,j)=a(i,j)-a(i,k)*a(k,j)
enddo
enddo
enddo
Passo 2: risolve il sistema con sostituzione all'indietro
x(n)=b(n)/a(n,n)
do i=n-1,1,-1
som=0
do j=i+1,n
som=som+a(i,j)*x(j)
enddo
x(i)=(b(i)-som)/a(i,i)
enddo
CALCOLO dell'AUTOVALORE MINIMO di una MATRICE (QUADRATA) con il
METODO DELLE POTENZE INVERSE
program autovalmin
parameter(ld=20,kmax=100)
real a(ld,ld), v0(ld), u(ld), beta(kmax)
write(*,*)'dimensione matrice'
read(*,*), n
write(*,*)'matrice per righe'
do i=1,n
read(*,*)(a(i,j), j=1,n)
enddo
write(*,*)'tolleranza e vettore normalizzato'
read(*,*) eps, (v0(i), i=1,n)
do k=1,kmax
call gauss(a,v0,n,ld)
call risolvi(a,u,v0,n,ld)
beta(k)=0.0
do i=1,n
11

eta(k)=beta(k)+u(i)*v0(i)
enddo
if(k.NE.1) then
if(abs(beta(k)-beta(k-1)).LE.eps*abs(beta(k))) then
open(unit=3, name='nomefile', form='formatted', status='new')
write(*,3) 'iterazione n° ', k
write(*,3) 'autovalore minimo = ',1/beta(k)
write(*,3) (v0(i), i=1,n)
close(3)
stop
endif
endif
gamma(k)=0.0
do i=1,n
gamma(k)=gamma(k)+u(i)*u(i)
enddo
gamma(k)=gamma(k)*v0
gamma(k)=sqrt(gamma(k))
do i=1,n
v0(i)=u(i)/gamma(k)
enddo
enddo
open(unit=3, name='nomefile', form='formatted', status='new')
write(*,3) 'iterazione n° ', kmax
write(*,3) 'autovalore minimo = ',1/beta(kmax)
write(*,3) (v0(i), i=1,n)
close(3)
end
RISOLUZIONE di un SISTEMA LINEARE Ax=b con MATRICE A PENTADIAGONALE
con il METODO di GAUSS (SENZA PIVOTING)
subroutine gausspentad(A,x,b,n,ld)
real a(ld,*), x(*), b(*)
Passo 1: ricava a triang. sup. e il b corrispondente
do k=1,n-1
do i=k+1,k+2
a(i,k)=a(i,k)/a(k,k)
b(i)=b(i)-a(i,k)*b(k)
do j=k+1,k+2
a(i,j)=a(i,j)-a(i,k)*(k,j)
enddo
enddo
enddo
Passo 2: risolve il sistema con sostituzione all'indietro
x(n)=b(n)/a(n,n)
do i=n-1,1,-1
s=0
do j=i+1,n
12

s=s+a(i,j)*b(j)
enddo
x(i)=(b(i)-s)/a(i,i)
enddo
return
end
RISOLUZIONE di un SISTEMA LINEARE Ax=b con MATRICE A EPTADIAGONALE
con il METODO di GAUSS (SENZA PIVOTING)
subroutine gausseptad(A,x,b,n,ld)
real a(ld,*), x(*), b(*)
Passo 1: ricava a triang. sup. e il b corrispondente
do k=1,n-1
do i=k+1,k+3
a(i,k)=a(i,k)/a(k,k)
b(i)=b(i)-a(i,k)*b(k)
do j=k+1,k+3
a(i,j)=a(i,j)-a(i,k)*(k,j)
enddo
enddo
enddo
Passo 2: risolve il sistema con sostituzione all'indietro
x(n)=b(n)/a(n,n)
do i=n-1,1,-1
s=0
do j=i+1,n
s=s+a(i,j)*b(j)
enddo
x(i)=(b(i)-s)/a(i,i)
enddo
return
end
RISOLUZIONE di un SISTEMA LINEARE Ax=b con MATRICE A TRIDIAGONALE con
il METODO di GAUSS (SENZA PIVOTING)
subroutine gausstrid(A,x,b,n,ld)
real a(ld,*), x(*), b(*)
Passo 1: ricava a triang. sup. e il b corrispondente
do k=1,n-1
a(k+1,k)=a(k+1,k)/a(k,k)
b(k+1)=b(k+1)-a(k+1,k)*b(k)
a(k+1,k+1)=a(k+1,k+1)-a(k+1,k)*(k,k+1)
enddo
Passo 2: risolve il sistema con sostituzione all'indietro
x(n)=b(n)/a(n,n)
do i=n-1,1,-1
13

s=0
do j=i+1,n
s=s+a(i,j)*b(j)
enddo
x(i)=(b(i)-s)/a(i,i)
enddo
return
end
PROVA SCRITTA 13/01/1998: ALGORITMO DELLA DECOMPOSIZIONE LU A
BLOCCHI
program 130198
parameter(ld=20)
real d1(ld,ld), d2(ld,ld), e(ld,ld), f(ld,ld), lf(ld,ld), ly(ld), fx(ld)
real f1(ld), f2(ld), f3(ld), e1(ld), e2(ld), e3(ld), u2(ld,ld)
real b1(ld), b2(ld), c1(ld), x1(ld), x2(ld)
open(unit=3, file='risul', form='formatted', status='new')
write(*,*)'Ordine delle matrici: '
read(*,*) n
write(*,*)'Diagonale principale della matrice diagonale D1'
read(*,*)(d1(i), i=1,n)
write(*,*)'Diagonale principale della matrice diagonale D2'
read(*,*)(d2(i), i=1,n)
write(*,*)'Diagonali della matrice tridiagonale F1'
diagonale sopra la principale
read(*,*)(f1(i), i=2,n)
diagonale principale
read(*,*)(f2(i), i=1,n)
diagonale sotto la principale
read(*,*)(f3(i), i=1,n-1)
write(*,*)'Diagonali della matrice tridiagonale F1'
diagonale sopra la principale
read(*,*)(e1(i), i=2,n)
diagonale principale
read(*,*)(e2(i), i=1,n)
diagonale sotto la principale
read(*,*)(e3(i), i=1,n-1)
costruzione delle matrici diagonali
do i=1,n
do j=1,n
if(j.eq.i) then
e(i,j)=e2(i)
f(i,j)=f2(i)
else
if(j.eq.i-1) then
e(i,j)=e1(i)
f(i,j)=f1(i)
else
14

if(j.eq.i+1) then
e(i,j)=e3(i)
f(i,j)=f3(i)
else
e(i,j)=0
f(i,j)=0
endif
endif
endif
enddo
enddo
write(*,*)'elementi dei termini noti'
read(*,*)(b1(i), i=1,n), (b2(i), i=1,n)
do i=1,n
write(*,*)(e(i,j), j=1,n)
enddo
do i=1,n
do j=1,n
e(i,j)=e(i,j)/d1(j)
enddo
enddo
do i=1,n
write(*,*)(e(i,j), j=1,n)
enddo
call matmat(e,f,lf,n,n,ld)
do i=1,n
write(*,*)(lf(i,j), j=1,n)
enddo
do i=1,n
do j=1,n
if(j.eq.i) then
u2(i,j)=d2(i)-lf(i,j)
else
u2(i,j)=-lf(i,j)
endif
enddo
enddo
do i=1,n
write(*,*)(u2(i,j), j=1,n)
enddo
call matmat(e,b1,ly,n,1,ld)
write(*,*)(ly(i), i=1,n)
do i=1,n
b2(i)=b2(i)-ly(i)
enddo
write(*,*)(b2(i), i=1,n)
call gauss(u2,x2,b2,n,ld)
write(*,*)(x2(i), i=1,n)
call matmat(f1,x2,fx,n,1,ld)
write(*,*)(fx(i), i=1,n)
do i=1,n
15

c1=b1(i)-fx(i)
enddo
write(*,*)(c1(i), i=1,n)
do i=1,n
x1(i)=c1(i)/d1(i)
enddo
write(*,*)(x1(i), i=1,n)
write(*,3)(x1(i), i=1,n)
stop
close(3)
end
NORMA di un VETTORE
real function norma(x,n,ld)
real x(*)
s=0.0
do i=1,n
s=s+x(i)**2
enddo
norma=sqrt(s)
return
end
NORMA all'INFINITO di una MATRICE QUADRATA
function ormat(a,n,ld)
real a(ld,*)
amax=0.0
do i=1,n
s=0.0
do j=1,n
s=s+abs(a(i,j))
enddo
if (amax.lt.s) then
amax=s
endif
enddo
ormat=amax
return
end
16

NORMA all'INFINITO di una MATRICE QUALSIASI
function ormatq(a,m,n,ld)
m righe n colonne
real a(ld,*)
amax=0.0
do i=1,m
s=0.0
do j=1,n
s=s+abs(a(i,j))
enddo
if (amax.lt.s) then
amax=s
endif
enddo
ormat=amax
return
end
FUNZIONE PRODOTTO SCALARE fra 2 VETTORI
real function prodscal(x,y,n,ld)
real x(*), y(*)
do i=1,n
p=p+x(i)*y(i)
enddo
prodscal=p
return
end
RISOLUZIONE di SISTEMA Ax=B con il METODO del GRADIENTE CONIUGATO
subroutine gradientec(a,xk,b,k,eps,n,ld)
real a(ld,*), xk(*), b(*), xk1(ld), rk(ld) rk1(ld), wk(ld), wk1(ld), pk(ld), pk1(ld)
kmax deve essere definito come parameter nel main del programma
call matvett(a,xk,rk,n,ld)
do i=1,n
rk(i)=b(i)-rk(i)
pk(i)=rk(i)
enddo
do k=0,kmax
if(norma(rk,n,ld).le.eps*norma(b,n,ld)) then
return
endif
17

call matvett(a,pk,wk,n,ld)
den=0.0
do i=1,n
den=den+wk(i)*pk(i)
enddo
alphak=norma(rk,n,ld)
alphak=(alphak**2)/den
do i=1,n
xk1(i)=xk(i)+alphak*pk(i)
rk1(i)=rk(i)-alphak*wk(i)
enddo
betak1=norma(rk1)
betak1=betak1**2
den=norma(rk)
den=den**2
betak1=betak1/den
do i=1,n
pk1(i)=rk1(i)+betak1*pk(i)
enddo
do i=1,n
rk(i)=rk1(i)
pk(i)=pk1(i)
enddo
enddo
return
end
PROVA SCRITTA 15/01/1999: METODO DI NEWTON GLOBALE
program 150199
parameter (ld=100,kmax=100)
real x0(ld), f(ld), fx(ld), jx(ld), dx(ld), z(ld), nfx(ld), fz(ld)
read (*,*) n, lambda, epsilon
read (*,*) (x0(i), i=1,n)
do i=1,n
do j=1,n
f(i,j) = 0
enddo
f(i,i)=4
enddo
do i=2,n
f(i,i-1) = -1
enddo
enddo
do i=3,n
f(i,i-2) = -1
enddo
18

do k=0,kmax
call matvet(f,x0,fx,n,ld)
do 1=1,n
fx(i)=fx(i) + lambda*(e**x0(i))
nfx(i)=-fx(i)
enddo
do i=1,n
do j=1,n
if (i.EQ.j) then
jx(i,j)=f(i,j)
endif
enddo
enddo
call triinf(jx,dx,nfx,n,ld)
do i=1,n
z(i) = x0(i)+ dx(i)
enddo
100 continue
call matvet(f,z,fz,n,ld)
do i=1,n
fz(i) = lambda*(e**z(i))
enddo
if (ormvett(fz,n,ld).GE.ormvett(fx,n,ld)) then
do i=1,n
dx(i)=dx(i)/2
z(i)=x0(i) + dx(i)
enddo
goto 100
endif
do i=1,n
x0(i)=z(i)
enddo
call matvet(f,x0,fx,n,ld)
do i=1,n
fx(i)=fx(i) + lambda*(e**x0(i)
enddo
if (ormvet(fx,n,ld).LE.epsilon) then
write(*,*)’soluzione: ‘ (x0(i),i=1,n)
stop
endif
enddo
write(*,*)’soluzione: ‘ (x0(i),i=1,n)
end
PROVA SCRITTA 7/07/1999: RICHIAMA IL METODO DEL GRADIENTE CONIUGATO
program 070799
parameter(ld=100, kmax=1000)
real a(ld,ld), b(ld), x0(ld)
open(unit=3, file='input', format='unformatted', access='sequential', status='old')
19

do i=1,n
read(3,*)(a(i,j), j=1,n)
enddo
read(3,*) (b(i), i=1,n)
read(3,*) (x0(i), i=1,n)
enddo
read(3,*) eps
close(3)
call gradientec(a,x0,b,k,epsn,ld)
open(unit=4, file='output', format='formatted', access='sequential', status='new')
write(*,4)(x0(i), i=1,n), k
close(4)
end
20

CALCOLO della MATRICE INVERSA di una MATRICE TRIANGOLARE INFERIORE
subroutine inversatriinf(a,z,n,ld)
real a(ld,*), z(ld,*)
do i=1,n
do j=1,n
if(i.eq.j) then
z(i,j)=1/a(j,j)
elseif(i.lt.j) then
z(i,j)=0.0
elseif(i.gt.j) then
s=0.0
do k=j,i-1
s=s+a(i,k)*a(k,j)
enddo
z(i,j)=((-1)**(i+j))*s/a(i,i)
endif
enddo
enddo
return
end
PROVA SCRITTA 11/01/2000: SISTEMA LINEARE DI m EQUAZIONI LINEARI A T x = b
program 11012000
parameter(ld=100)
real a(ld,ld), xk(ld), b(ld), ar(ld), xk1(ld), diff(ld)
legge il numero di righe (n) e di colonne (m) di A
read(*,*) n,m
do i=1,m
read(*,*)(a(i,j), j=1,n)
enddo
read(*,*)(xk(i), i=1,n)
read(*,*)(b(i), i=1,m)
read(*,*) eps
write(*,*)'Norma infinito di A = ', ormatq(a,n,m,ld)
k=0
100 continue
r=mod(k,m)+1
do i=1,n
ar(i)=a(i,r)
enddo
alphak=(b(r)-prodscal(ar,xk,n,ld))/prodscal(ar,ar,n,ld)
do i=1,n
xk1(i)=xk(i)+alphak*ar(i)
diff(i)=xk1(i)-xk(i)
enddo
if(ormavett(diff,n,ld).le.eps*ormavett(xk1,n,ld)) then
21

goto 1000
endif
k=k+1
do i=1,n
xk(i)=xk1(i)
enddo
goto 100
1000 continue
write(*,*)'iterazione ', k
write(*,*)'risultato = ',(xk1(i), i=1,n)
end
PRODOTTO di KRONECKER
subroutine cronecker(a,b,c,n,ld1,ld2)
ld2=ld1**2
real a(ld1,*), b(ld1,*), c(ld2,*)
integer p, q
p=0
do i=1,n
q=0
do j=1,n
do k=1,n
do l=1,n
c(k+p,l+q)=a(i,j)*b(k,l)
enddo
enddo
q=q+n
enddo
p=p+n
enddo
return
end
PROVA SCRITTA 23/02/2000: CALCOLO DELLA MATRICE p(A) = I + A + A 2 + … + A K
program 23022000
parameter(ld=100)
real a(ld,ld), pa(ld,ld), ak(ld,ld), ak1(ld,ld)
read(*,*) n, k
do i=1,n
read(*,*)(a(i,j), j=1,n)
enddo
do i=1,n
do j=1,n
22

if(i.eq.j) then
pa(i,j)=a(i,j)+1.0
else
pa(i,j)=a(i,j)
endif
ak(i,j)=a(i,j)
enddo
enddo
do l=2,k
call matqmatq(a,ak,ak1,n,n,n,ld)
call sommamatrici(pa,ak1,pa,n,ld)
do i=1,n
do j=1,n
ak(i,j)=ak1(i,j)
enddo
enddo
enddo
write(*,*)'Norma infinito = ',ormat(pa,n,ld)
end
23