So, I'm currently writing a small scale code that does output using CGNS and adaptive mesh refinement (AMR) with Amrex. This is all being done with Fortran 95, though CGNS is C with Fortran interfaces and Amrex is C++ with Fortran interfaces (those are not in the sample code). I'm using OpenMPI 1.10.7.
This will eventually go into a full CFD code, but I wanted to test it small scale to work the bugs out before putting in the larger code. The program below seems to works every time, but it was originally a subroutine that did not.
I'm having an issue where not all of the data from MPI_Bcast is being received by every process... sometimes. I can hit execute on the same code, twice in a row and sometimes is bombs out (segfault from CGNS elsewhere in the code, and sometimes it works. As far as I can tell, the program bombs when not all of the data from MPI_Bcast is received in time to start work elsewhere. Despite MPI_wait and MPI_barrier, the writes at the bottom in the subroutine will spit out junk on lvl=1 for the last six indices of all the arrays. Printing information to the screen seems to help, but more processors seem to lower the likelihood of the code working.
I've currently got it as MPI_ibcast with an MPI_wait, but I've also tried MPI_Bcast with MPI_barriers after. Changing the communicator from one defined by Amrex to MPI_COMM_WORLD doesn't help.
...
program so_bcast
!
!
!
!
use mpi
implicit none
integer :: lvl,i,a,b,c,ier,state(MPI_STATUS_SIZE),d
integer :: n_elems,req,counter,tag,flavor
integer :: stat(MPI_STATUS_SIZE)
integer :: self,nprocs
type :: box_zones
integer,allocatable :: lower(:,:),higher(:,:),little_zones(:)
double precision,allocatable :: lo_corner(:,:),hi_corner(:,:)
integer :: big_zones
integer,allocatable :: zone_start(:),zone_end(:)
end type
type(box_zones),allocatable :: zone_storage(:)
call MPI_INIT(ier)
call MPI_COMM_SIZE(MPI_COMM_WORLD,nprocs,ier)
call MPI_COMM_RANK(MPI_COMM_WORLD,self,ier)
lvl = 1
! Allocate everything, this is done elsewhere in the actual code, but done here
! for simplification reasons
allocate(zone_storage(0:lvl))
zone_storage(0)%big_zones = 4
zone_storage(1)%big_zones = 20
do i = 0,lvl
allocate(zone_storage(i)%lower(3,zone_storage(i)%big_zones))
allocate(zone_storage(i)%higher(3,zone_storage(i)%big_zones))
allocate(zone_storage(i)%lo_corner(3,zone_storage(i)%big_zones))
allocate(zone_storage(i)%hi_corner(3,zone_storage(i)%big_zones))
zone_storage(i)%lower = self
zone_storage(i)%higher = self*2+1
zone_storage(i)%lo_corner = self*1.0D0
zone_storage(i)%hi_corner = self*1.0D0+1.0D0
allocate(zone_storage(i)%zone_start(0:nprocs-1))
allocate(zone_storage(i)%zone_end(0:nprocs-1))
zone_storage(i)%zone_start(self) = zone_storage(i)%big_zones/nprocs*self+1
zone_storage(i)%zone_end(self) = zone_storage(i)%zone_start(self)+zone_storage(i)%big_zones/nprocs-1
if (zone_storage(i)%zone_end(self)>zone_storage(i)%big_zones) zone_storage(i)%zone_end(self) = zone_storage(i)%big_zones
end do
do i = 0,lvl
write(*,*) 'lower check 0',self,'lower',zone_storage(i)%lower
write(*,*) 'higher check 0',self,'high',zone_storage(i)%higher
write(*,*) 'lo_corner check 0',self,'lo_corner',zone_storage(i)%lo_corner
write(*,*) 'hi_corner check 0',self,'hi_corner',zone_storage(i)%hi_corner
write(*,*) 'big_zones check 0',self,'big_zones',zone_storage(i)%big_zones
write(*,*) 'zone start/end 0',self,'lvl',i,zone_storage(i)%zone_start,zone_storage(i)%zone_end
end do
!
! Agglomerate the appropriate data to processor 0 using non-blocking receives
! and blocking sends
!
do i = 0,lvl
do a = 0,nprocs-1
call mpi_bcast(zone_storage(i)%zone_start(a),1,&
MPI_INT,a,MPI_COMM_WORLD,ier)
call mpi_bcast(zone_storage(i)%zone_end(a),1,&
MPI_INT,a,MPI_COMM_WORLD,ier)
end do
end do
call MPI_BARRIER(MPI_COMM_WORLD,ier)
counter = 0
do i = 0,lvl
n_elems = 3*zone_storage(i)%big_zones
write(*,*) 'number of elements',n_elems
if (self == 0) then
do a = 1,nprocs-1
do c = zone_storage(i)%zone_start(a),zone_storage(i)%zone_end(a)
tag = c*100000+a*1000+1!+d*10
call mpi_irecv(zone_storage(i)%lower(1:3,c),3,MPI_INT,a,&
tag,MPI_COMM_WORLD,req,ier)
tag = tag + 1
call mpi_irecv(zone_storage(i)%higher(1:3,c),3,MPI_INT,a,&
tag,MPI_COMM_WORLD,req,ier)
tag = tag +1
call mpi_irecv(zone_storage(i)%lo_corner(1:3,c),3,MPI_DOUBLE_PRECISION,a,&
tag,MPI_COMM_WORLD,req,ier)
tag = tag +1
call mpi_irecv(zone_storage(i)%hi_corner(1:3,c),3,MPI_DOUBLE_PRECISION,a,&
tag,MPI_COMM_WORLD,req,ier)
end do
end do
else
do b = zone_storage(i)%zone_start(self),zone_storage(i)%zone_end(self)
tag = b*100000+self*1000+1!+d*10
call mpi_send(zone_storage(i)%lower(1:3,b),3,MPI_INT,0,&
tag,MPI_COMM_WORLD,ier)
tag = tag + 1
call mpi_send(zone_storage(i)%higher(1:3,b),3,MPI_INT,0,&
tag,MPI_COMM_WORLD,ier)
tag = tag + 1
call mpi_send(zone_storage(i)%lo_corner(1:3,b),3,MPI_DOUBLE_PRECISION,0,&
tag,MPI_COMM_WORLD,ier)
tag = tag +1
call mpi_send(zone_storage(i)%hi_corner(1:3,b),3,MPI_DOUBLE_PRECISION,0,&
tag,MPI_COMM_WORLD,ier)
end do
end if
end do
write(*,*) 'spack'
!
call mpi_barrier(MPI_COMM_WORLD,ier)
do i = 0,lvl
write(*,*) 'lower check 1',self,'lower',zone_storage(i)%lower
write(*,*) 'higher check 1',self,'high',zone_storage(i)%higher
write(*,*) 'lo_corner check 1',self,'lo_corner',zone_storage(i)%lo_corner
write(*,*) 'hi_corner check 1',self,'hi_corner',zone_storage(i)%hi_corner
write(*,*) 'big_zones check 1',self,'big_zones',zone_storage(i)%big_zones
write(*,*) 'zone start/end 1',self,'lvl',i,zone_storage(i)%zone_start,zone_storage(i)%zone_end
end do
!
! Send all the data out to all the processors
!
do i = 0,lvl
n_elems = 3*zone_storage(i)%big_zones
req = 1
call mpi_ibcast(zone_storage(i)%lower,n_elems,MPI_INT,&
0,MPI_COMM_WORLD,req,ier)
call mpi_wait(req,stat,ier)
write(*,*) 'spiffy'
req = 2
call mpi_ibcast(zone_storage(i)%higher,n_elems,MPI_INT,&
0,MPI_COMM_WORLD,req,ier)
call mpi_wait(req,stat,ier)
req = 3
call mpi_ibcast(zone_storage(i)%lo_corner,n_elems,MPI_DOUBLE_PRECISION,&
0,MPI_COMM_WORLD,req,ier)
call mpi_wait(req,stat,ier)
req = 4
call mpi_ibcast(zone_storage(i)%hi_corner,n_elems,MPI_DOUBLE_PRECISION,&
0,MPI_COMM_WORLD,req,ier)
call mpi_wait(req,stat,ier)
call mpi_barrier(MPI_COMM_WORLD,ier)
end do
write(*,*) 'lower check 2',self,'lower',zone_storage(lvl)%lower
write(*,*) 'higher check 2',self,'high',zone_storage(lvl)%higher
write(*,*) 'lo_corner check ',self,'lo_corner',zone_storage(lvl)%lo_corner
write(*,*) 'hi_corner check ',self,'hi_corner',zone_storage(lvl)%hi_corner
write(*,*) 'big_zones check ',self,'big_zones',zone_storage(lvl)%big_zones
call MPI_FINALIZE(ier)
end program
...
As I said, this code works, but the larger version does not always work. OpenMPI throws several warnings akin to this:
mca: base: component_find: ess "mca_ess_pmi" uses an MCA interface that is not recognized (component MCA v2.1.0 != supported MCA v2.0.0) -- ignored
mca: base: component_find: grpcomm "mca_grpcomm_direct" uses an MCA interface that is not recognized (component MCA v2.1.0 != supported MCA v2.0.0) -- ignored
mca: base: component_find: rcache "mca_rcache_grdma" uses an MCA interface that is not recognized (component MCA v2.1.0 != supported MCA v2.0.0) -- ignored
etc. etc. But the program can still complete even with those warnings.
-Is there a way to ensure that MPI_bcast has emptied its buffer into the correct region of memory before moving on? It seems to miss this sometimes.
-Is there a different/better method to distribute the data? The sizes have to be able to vary unlike the test program.
Thank you ahead of time.
The most straightforward answer was to use MPI_allgatherv. As little as I wanted to mess with displacements, it was the best setup to share the information and reduce overall code length.
I believe a MPI_waitall solution would work too, as the data was not being fully received before being broadcast.
Suppose I have the matrix c(i,j). I want to write it on the screen on oldest Fortran77 language with three signs after comma. I write
do i=1,N
write(*,"(F8.3)") ( c(i,j), j=1,N )
end do
but the output is in the form
c(1,1)
c(1,2)
...
c(1,10) c(2,1)
c(2,2)
...
Finally, I may simply write
do i=1,N
write(*,*) ( c(i,j), j=1,N )
end do
and then the output is like the matrix, but, of course, it is not formatted.
How to get the correct output in Fortran77?
An edit. It seems that one of solutions is to write
do i=1, N
do j=1, N
write(*,'(F9.3,A,$)') c(i,j), ' '
end do
write(*,*) ' '
end do
Your format only specifies a single float but you actually want to write N per line.
A fairly general solution for this simple case would be something like
program temp
implicit none
integer, parameter :: N=3
real, dimension(N,N) :: c
integer :: i,j
character(len=20) :: exFmt
c = 1.0
write(exFmt,'("(",I0,"(F8.3))")') N
do i=1,N
write(*,exFmt) (c(i,j), j=1,N)
end do
end program
This will make exFmt be '(3(F8.3))', which specifies printing three floats (note you probably really want '(3(F8.3," "))' to explicitly include some spacing).
Note some compilers will allow for exFmt to be just '(*(F8.3))'. This is part of the fortran 2008 specification so may not be provided by all compilers you have access to. See here for a summary of compiler support (see Unlimited format item, thanks to HighPerformanceMark for this)
Finally an easy bodge is to use a format statment like '(1000(F8.3))' where 1000 is larger than you will ever need.
I want to wrap the fortran write-statement in a custom subroutine or function which includes some additional debug-logic.
But I'm currently stuck with defining the prototype of the function/subroutine.
Is this possible? If yes, how?
The title of your question exhibits a misunderstanding, though the text suggests you know better. Nevertheless, for the record, write is a Fortran statement, it is neither a subroutine nor a function.
I think you have a number of options. One, which I have used occasionally, would be to write a function which returns a string. Perhaps
function error_message(error)
character(len=*), intent(in) :: error
character(len=:), allocatable :: error_message
error_message = 'ERROR: '//trim(error)
end function error_message
which you can then use like this
write(*,*) error_message('Oh s**t')
You could certainly write a subroutine or a function with side effects which include writing to an ouput channel, but if you adopt this approach you have to be careful to observe the rules for recursive i/o.
EDIT
after OP's comment.
If you want to switch off debug messages another option you have is to direct them to a null device or file, eg /dev/null on Linux or NUL on Windows. Something like
integer, parameter :: debug_channel = 99
logical, parameter :: debugging = .false.
...
if (debugging) then
open(debug_channel, file='NUL')
else
open(debug_channel, file='debuglog'
end if
and then
write(debug_channel,*) 'message'
a relatively simple way to accomplish most of what you want is to simply put the if inline in front of every write that is subject to debug control:
if(debug)write(..,..)..
where debug is a global logical value, or even:
if(debugf(level))write(..,..)..
where the logical function debugf determines whether to write based on some argument.
In addition to the other answers, you may be able to avoid using if (debug) write... with derived type IO.
I say "may", as it is quite silly unless you already have a suitable structure, and compiler support is currently rare.
However, as an example, compiled with ifort 14.0.1:
module errormod
type error_t
character(len=:), allocatable :: message
contains
procedure write_error
generic :: write(formatted) => write_error
end type error_t
logical debug_verbose
contains
subroutine write_error(err, unit, iotype, v_list, iostat, iomsg)
class(error_t), intent(in) :: err
integer, intent(in) :: unit
character(len=*), intent(in) :: iotype
integer, intent(in), dimension(:) :: v_list
integer, intent(out) :: iostat
character(len=*), intent(inout) :: iomsg
if (debug_verbose) then
write(unit, '("Error: ", A)', iostat=iostat, iomsg=iomsg) err%message
else
write(unit, '()', advance='no')
end if
end subroutine write_error
end module errormod
program test
use errormod
implicit none
type(error_t) error
debug_verbose = .TRUE.
error%message = "This error will be reported."
write(*, '(dt)') error
debug_verbose = .FALSE.
error%message = "This error will not be reported."
write(*, '(dt)') error
debug_verbose = .TRUE.
error%message = "This final error will also be reported."
write(*, '(dt)') error
end program test
The first and third messages will appear, but not the second.
I want to know if there is any intrinsic function which converts date to DDMonYY format in fortran.
As I know Idate returns a date in DDMMYYY.But I would like to know how to get date format in DDMonYY.Do I need to write a separate program which extracts month from Idate and writes character equivalent (like 1 for Jan)
There is the DATE_AND_TIME intrinsic which can return the information you want, with the exception that you get the month as a numeric value in the second element of the VALUES argument. It should then be quite easy to use that month number as the index into a character array with the (3 letter) month names.
Here's a routine that does what you want and a quick program that tests it:
PROGRAM date_test
CHARACTER(len=7) :: date
CALL get_DDMonYY(date)
PRINT*, date
CONTAINS
SUBROUTINE get_DDMonYY(date)
CHARACTER(len=7), INTENT(out) :: date
CHARACTER(len=2) :: dd
CHARACTER(len=3) :: mons(12)
CHARACTER(len=4) :: yyyy
INTEGER :: values(8)
mons = ['Jan','Feb','Mar','Apr','May','Jun',&
'Jul','Aug','Sep','Oct','Nov','Dec']
CALL DATE_AND_TIME(VALUES=values)
WRITE( dd,'(i2)') values(3)
WRITE(yyyy,'(i4)') values(1)
date = dd//mons(values(2))//yyyy(3:4)
END SUBROUTINE get_DDMonYY
END PROGRAM date_test
AFAIK there is no such intrinsic, but it is not at all difficult to write an own subroutine to do that. You Just need to use something as
write(mydate(3:5),fmt='(a3)') 'Jan'
where mydate is the character which will contain DDMonYY.