var
  s:array[1..100,1..100]of integer;
  i,j,k,l,m,n:integer;

begin
  readln(n);m:=1;i:=1;j:=1;
  if n=1 then begin writeln('    1'); exit; end;
  for k:=1 to n-1 do
    begin
      for l:=1 to n-k+1-(k-1) do begin   if s[i,j]<>0 then break; s[i,j]:=m; inc(j); inc(m); end; inc(i); dec(j);
      for l:=1 to n-k-1-(k-1) do begin   if s[i,j]<>0 then break; s[i,j]:=m; inc(i); inc(m); end;
      for l:=1 to n-k+1-(k-1) do begin   if s[i,j]<>0 then break; s[i,j]:=m; dec(j); inc(m); end; inc(j); dec(i);
      for l:=1 to n-k-1-(k-1) do begin   if s[i,j]<>0 then break; s[i,j]:=m; dec(i); inc(m); end; inc(i); inc(j);
        if s[i,j]<>0 then break;
    end;

  for i:=1 to n do
    begin
      for j:=1 to n do
        write(s[i,j]:5);
      writeln;
    end;
end.

太谢谢了

Var
          j:Integer;
          n,i,k,x,y,Number:Byte;
          Result:Array[1..25,1..25] of Byte;
       Begin
            Write('N='); Readln(n);
            For x:=1 to n do for y:=1 to n do Result[x,y]:=0; {初始化数组}
            X:=0; Y:=N; i:=0; k:=N; j:=1;
             {j表示填数方向。从左→右或从上→下，j＝1；否则j=-1}
            While i<N*N do
                  Begin
                       For i:=i+1 to i+k do    {纵向填 k 个数}
                           Begin
                                X:=X+j;
                                Result[x,y]:=i;
                           End;
                       Dec(k); {K:填多少个数,其规律是递减:n,n-1,n-2,......,2,1}
                       If j=1 then j:=-1 else j:=1;  {改变方向}
                       For i:=i+1 to i+k do          {横向填 k 个数}
                           Begin
                                y:=y+j;
                                Result[x,y]:=i;
                           End;
                  End;
            For x:=1 to n do   {输出}
                Begin
                     For y:=1 to n do Write(Result[x,y]:3);
                     Writeln;
                End;
       End.