external F
          Dimension a(5,6),B(5)      
          Real a,B
          Integer I,j
           data A/5.3,-0.25,1.35,2.25,-0.5,2.1,7.1,-2.5,0.9,-1.7,-3.2,4.3,6.83,-4.3,3.7,-1.25,-0.7,0.35,5.25,-1.25,0.5,-1.1,1.8,-0.83,8.9,-3.05,0.15,-1.7,4.1,2.0/
           !read(*,*)A
           write(*,45)
            45 format(6x,'Matrica A')
                   write(*,76)((A(i,j),j=1,6,1),i=1,5,1)
                    76 format(6(3x,f5.2))
 


Do j=1,6,1
     Do i=1,5,1       
        B(i)=0             
        B(i)=A(I,j)         
      enddo           
               call RAZD(B,5,F,L) 
            do i=1,5,1
               a(i,j)=b(i)  
            enddo
enddo
write(*,*)'in UPOR'
pause
write(*,*) 'out Upor'                
! call Upor(a,5,6) 
write(*,55)
55 format(6x, 'perestavlennaya Matrica A')
write(*,76)((a(i,j),j=1,6,1),i=1,5,1)
END



Real function F(x)
real x
F=x
return
end


 
 
 Subroutine RAZD (A, m, F, K)
Dimension A(M)
Integer i, j, m, k
logical p 
Real A,x
i=1
j=M
   do while (i<j)
      if (F(A(i)).GE.0) then
         p=.true.
              do while (j>i .and. P)
                  If (F(A(j))<0) then 
                    x=a(i)
                    A(i)=A(j)
                    A(j)=x
                    p=.false.
                  endif
                j=j-1
              enddo
      Endif
    i=i+1
    Enddo
if (j.eq.M) then
k=j+1
else
     If (p) then 
      k=i-1
          else
          k=j
     Endif
Endif
return
end

Uses CRT;

Const
 M=5;
 N=6;

Type
 Matr=Array[1..M,1..N] of Real;
 Vect=Array[1..M] of Real;

Const
 A:Matr=(( 5.30,  2.10, -3.20, -1.25,  0.50, -3.05),
         (-0.25,  7.10,  4.30, -0.70,-11.00,  0.15),
         ( 1.35, -2.50,  6.83,  0.35,  1.80, -1.70),
         ( 2.25,  0.90, -4.30,  5.25, -0.83,  4.10),
         (-0.50, -1.70, -3.70, -1.25,  8.90,  2.00));

Procedure Razd(var R:Vect; var Nr:Byte);
var
 k,l,p:byte;
 d:real;
 bu:boolean;
begin
 p:=1;
 for k:=1 to M do
  begin
   if R[k]<0 then Inc(p)
   else
    begin
     bu:=false;
     l:=k;
     repeat
      Inc(l);
      if l<=M then
       if R[l]<0 then
        begin
         d:=R[k];
         R[k]:=R[l];
         R[l]:=d;
         Inc(p);
         bu:=true;
        end;
     until bu or (l>=M);
    end;
  end;
 Nr:=p;
end;

Procedure Upor(g:byte; var U:vect);
var
 p,q:Byte;
 d:Real;
begin
 for p:=g to M-1 do
  for q:=g to M-p+g-1 do
   if U[q]<U[q+1] then
    begin
     d:=U[q];
     U[q]:=U[q+1];
     U[q+1]:=d;
    end;
end;

Procedure Output(T:Matr);
var p,q:Byte;
begin
 for p:=1 to M do
  begin
   for q:=1 to N do
    write(T[p,q]:8:2);
   writeln;
  end;
 writeln;
end;

Var
 B:Matr;
 V:Vect;
 i,j:Byte;
 Nom:Array[1..N] of Byte;

Begin
 ClrScr;
 B:=A;
 Output(B);
 for j:=1 to N do
  begin
   for i:=1 to M do V[i]:=B[i,j];
   Razd(V,Nom[j]);
   for i:=1 to M do B[i,j]:=V[i];
  end;
 Output(B);
 for j:=1 to N do
  begin
   for i:=1 to M do V[i]:=B[i,j];
   Upor(Nom[j],V);
   for i:=1 to M do B[i,j]:=V[i];
  end;
 Output(B);
 ReadKey
End.