MPIを用いたプログラムでパラメータを外部ファイルから入力するためのサンプルプログラム

Fortranプログラムにおいて、d:id:rigarash:20100201:1264984235で書いたように、namelistからの入力は強力なのですが、MPI並列化のプログラムでは、コマンドラインなどにアクセスできるのは1ノードだけだったりするので、ポータブルに読み込むにはもう少し注意が必要です。少なくともIntel Fortran 11.0 + Intel MPI 3.1.0 と gfortran 4.4.3 + OpenMPI 1.3.3 (Debian GNU/Linux (sid))でうまく動き、できるだけ標準(Fortran2003含む)に準拠したサンプルを書いてみました。

program main
  implicit none
  include "mpif.h"

  integer :: a,b,c
  integer :: res
  integer, dimension(:), allocatable :: resv

  integer :: clcount
  character(len=256) :: arg
  integer :: arglen
  integer :: ioerr,mpierr
  integer :: i,j

  integer :: rank,np

  namelist /param/ a,b,c
  a=1
  b=2
  c=3

  call MPI_Init(mpierr)
  call MPI_Comm_rank(MPI_COMM_WORLD,rank,mpierr)
  call MPI_Comm_size(MPI_COMM_WORLD,np,mpierr)

  if (rank == 0) then
     clcount=command_argument_count()
  endif
  call MPI_Bcast(clcount,1,MPI_INTEGER,0,MPI_COMM_WORLD,mpierr)
  if (clcount == 0) then
     call stop_program(rank,np,"*** no input file specified. ***")
  endif
  if (rank == 0) then
    allocate(resv(np),stat=ioerr)
  endif
  call MPI_Bcast(ioerr,1,MPI_INTEGER,0,MPI_COMM_WORLD,mpierr)
  if (ioerr > 0) then
     call stop_program(rank,np,"*** result vector allocation fails ***")
  endif
  do i=1,clcount
     if (rank == 0) then
        call get_command_argument(i,arg,arglen,ioerr)
     endif
     call MPI_Bcast(ioerr,1,MPI_INTEGER,0,MPI_COMM_WORLD,mpierr)
     if (ioerr > 0) then
        call stop_program(rank,np,"*** input file name retrieval fails ***")
     elseif (ioerr == -1) then
        call stop_program(rank,np,"*** input file name too long ***")
     endif
     if (rank == 0) then
        open(unit=100,file=arg,iostat=ioerr)
     endif
     call MPI_Bcast(ioerr,1,MPI_INTEGER,0,MPI_COMM_WORLD,mpierr)
     if (ioerr > 0) then
        call stop_program(rank,np,"*** Cannot open input file ***")
     endif
     if (rank == 0) then
        read(unit=100,nml=param,iostat=ioerr)
        if (ioerr < 0) then
           print*,"*** parameter reading FAILED. Use default value instead ***"
        endif
        close(unit=100)
        write(unit=6,nml=param)
     endif
     call MPI_Bcast(a,1,MPI_INTEGER,0,MPI_COMM_WORLD,mpierr)
     call MPI_Bcast(b,1,MPI_INTEGER,0,MPI_COMM_WORLD,mpierr)
     call MPI_Bcast(c,1,MPI_INTEGER,0,MPI_COMM_WORLD,mpierr)
     res = a + b + c
     call MPI_gather(res,1,MPI_INTEGER,resv,1,MPI_INTEGER,0,MPI_COMM_WORLD,mpierr)
     if (rank == 0) then
        do j=1,np
           write(6,*), j,resv(j)
        enddo
     endif
     deallocate(resv,stat=ioerr)
  enddo
  call stop_program(rank,np,"")
end program main

subroutine stop_program(rank,np,text)
  implicit none
  include "mpif.h"

  integer :: rank,np
  integer :: mpierr
  character(*) :: text

  if (rank == 0) then
     write(6,*), trim(text)
  endif
  call MPI_finalize(mpierr)
  stop
end subroutine stop_program