corrections TD FORTRAN : bibliothèque tableaux
Licence Techno Méca
c -------------------------------------------------------------------
c bibliothèque de fonctions utilitaires pour tableaux de réels :
c saisie, affichage, moyenne, copie, ajout et suppression, tris
c
c copyright LTM - P.Trau - IPST Strasbourg 2003
c
c -------------------------------------------------------------------
c affichage d'un tableau de réels
c arguments non modifiés : le tableau (tab), le nombre d'éléments (n)
c -------------------------------------------------------------------
subroutine affiche(tab,n)
implicit none
integer n
real tab(*)
integer i
print *,'le tableau contient ',n,' éléments'
do 10 i=1,n
print *,i, '->', tab(i)
10 continue
end subroutine affiche
c -------------------------------------------------------------------
c saisie d'un tableau de réels (son nombre d'éléments n puis les n éléments)
c arguments modifiés : le tableau (tab), le nombre d'éléments (n)
c arguments non modifiés : la dimension réelle de tab (max)
c -------------------------------------------------------------------
subroutine saisie(tab,n,max)
implicit none
integer n,max
real tab(*)
integer i
print *,'combien d''éléments ?'
read *,n
if (n.gt.max.or.n.le.0) then
print *,'pas possible !'
stop
endif
do 20 i=1,n
print *,i, '->'
read *,tab(i)
20 continue
end subroutine saisie
c -------------------------------------------------------------------
c calcul de la moyenne d'un tableau de réels
c arguments non modifiés : le tableau (t), le nombre d'éléments (nb)
c -------------------------------------------------------------------
real function moyenne(t,nb)
implicit none
integer nb
real t(*)
integer i
real somme
somme=0
do 30 i=1,nb
somme=somme+t(i)
30 continue
moyenne=somme/nb
end function moyenne
c -------------------------------------------------------------------
c copie d'un tableau de réels dans un autre (source vers destination)
c arguments modifiés : le tableau destination et son nombre d'éléments (nbdest)
c arguments non modifiés : le tableau (source)et son nombre d'éléments (nbsrc)
c -------------------------------------------------------------------
subroutine copie (source,destination,nbsrc,nbdest)
implicit none
integer nbsrc,nbdest
real source(*),destination(*)
integer i
nbdest=nbsrc
do 10 i=1,nbsrc
destination(i)=source(i)
10 continue
end subroutine copie
c -------------------------------------------------------------------
c suppression d'une valeur dans un tableau de réels
c arguments modifiés : le tableau et son nombre d'éléments
c arguments non modifiés : l'indice (position) du pt à supprimer
c -------------------------------------------------------------------
subroutine supvaleur (tab,nb,position)
implicit none
real tab(*)
integer i,nb,position
if(position.lt.1.or.position.gt.nb)return
do 22 i=position,nb-1
tab(i)=tab(i+1)
22 continue
nb=nb-1
end subroutine supvaleur
c -------------------------------------------------------------------
c ajout d'une valeur dans un tableau de réels
c arguments modifiés : le tableau et son nombre d'éléments
c arguments non modifiés : l'indice (position) et la valeur à ajouter
c -------------------------------------------------------------------
subroutine ajvaleur (tab,nb,position,valeur)
implicit none
real valeur,tab(*)
integer i,nb,position
if(position.lt.1.or.position.gt.nb+1)return
do 23 i=nb,position,-1
tab(i+1)=tab(i)
23 continue
tab(position)=valeur
nb=nb+1
end subroutine ajvaleur
c -------------------------------------------------------------------
c tri du tableau tab (nb éléments) (tri bulle optimisé)
c -------------------------------------------------------------------
subroutine tribulle (tab,nb)
implicit none
real tab(*),tmp
integer nb,i
logical test
test=.true.
do while (test)
test=.false.
do 20 i=1,nb-1
if(tab(i).gt.tab(i+1))then
tmp=tab(i)
tab(i)=tab(i+1)
tab(i+1)=tmp
test=.true.
endif
20 continue
enddo
end subroutine tribulle
c -------------------------------------------------------------------
c recherche de l'indice du plus petit élément de la plage [deb,fin]
c du tableau tab. Aucun argument n'est modifié
c -------------------------------------------------------------------
integer function idpp(tab,deb,fin)
implicit none
real tab(*)
integer deb,fin,ipp,nb,i,j
ipp=deb
do 10 i=deb+1,fin
if(tab(i).lt.tab(ipp))ipp=i
10 continue
idpp=ipp
end function idpp
c -------------------------------------------------------------------
c tri du tableau tab (nb éléments) (tri sélection)
c -------------------------------------------------------------------
subroutine triselection (tab,nb)
implicit none
real tab(*),tmp
integer j,i,idpp,nb
do 20 i=1,nb-1
j=idpp(tab,i,nb)
if(i.ne.j)then
tmp=tab(i)
tab(i)=tab(j)
tab(j)=tmp
endif
20 continue
end subroutine triselection
c -------------------------------------------------------------------
c tri du tableau tab (nb éléments) (tri insertion)
c -------------------------------------------------------------------
subroutine triinsertion(tab,nb)
implicit none
real tab(*),tmp
integer i,idpp,nb,j,k
do 10 i=1,nb
j=idpp(tab,i,nb)
if(i.ne.j)then
tmp=tab(j)
do 20 k=j-1,i,-1
tab(k+1)=tab(k)
20 continue
tab(i)=tmp
endif
10 continue
end subroutine triinsertion
c -------------------------------------------------------------------