求出n取k組合的列表 Fortran 版

這次換個簡單一點的語言：Fortran 95。
我很驚訝GFortran 4.7仍然預設是Fortran 77，所以副檔名若是.f或.for會錯, 要存成.f90或.f95才行。

Fortran是Column major語言，所以若要遞迴還需要宣告recursive，堆疊方式造成Fortran永遠處理遞迴會比C麻煩。再加上很遜的Format，我就用以前學的Fortran 77寫法完成 :P。

program Combinations
  implicit none
  integer, parameter :: all=5
    integer, parameter :: want=2
    integer :: currentrow 
  integer, dimension(:, :), pointer :: result
  call comb(all, want)


 contains
  function factorial(n)
   integer:: n, factorial, i
   factorial = product((/(i, i=1, n)/))
  end function

  subroutine addlist(before, beforelength, left, leftlength)
   integer, intent(in), dimension(0:)::before, left
   integer, intent(in) :: beforelength, leftlength
   integer ::i, j
   do i = 0, beforelength-1
    result(currentrow, i) = before(i)
   end do 
   do j=0, leftlength-1
    result(currentrow, i+j) = left(j)
   end do
   currentrow = currentrow + 1
  end subroutine

  subroutine comb(all, want)
   integer, intent(in) ::all, want
   integer :: resultno, i, j
   integer, dimension(0) :: before
   character (500) :: fmt
   fmt = '(i0' // repeat (', 1x, i0', all - 1) // ')'
   currentrow = 0
     resultno = factorial(all)/ ((factorial(want)* factorial(all-want)))
     allocate(result(resultno, all))
     write(*, "(a4, i2, a4)") "共:", resultno, "筆"
   call calc(before, 0, all, want)
   write (*, *) 'currentrow=', currentrow, ' all=', all
   do i=0, currentrow-1
    write (*, fmt)   (result(i, j), j=0, all-1)
   end do 
  end subroutine

 recursive subroutine calc(before, beforelength, all, want)
  integer, dimension(0:) :: before
  integer, intent(in) :: beforelength, all, want
  integer :: i, leftlength
  integer, dimension(0:all) :: strall, newbefore, left
  if (want == 0) then
   do i=1, all
    strall(i) = 0
   end do
   call addList(before, beforelength, strall, all)
  else if (all==want) then
   do i=0, all-1
    strall(i) = 1
   end do  
   call addList(before, beforelength, strall, all)
  else if(all == 1) then
   leftlength = 1
   select case(want)
    case (0)
     left(0)=0
    case (1)
     left(0)=1   
   end select
   call addlist(before, beforelength,  left, leftlength);
  else
   do i=0, beforelength-1
    newbefore(i) = before(i)
   end do
   newbefore(i) = 0
   call calc(newbefore, beforelength+1, all-1, want)
   newbefore(i) = 1
   call calc(newbefore, beforelength+1, all-1, want-1)
  end if
 end subroutine
 end program main