I have found written
"A message can ONLY be received within the same communicator from which it was sent".
However, if I look at this picture
https://imgur.com/a/hYz4dWd
and then analyze this code
Send and Receive operations between communicators in MPI
use mpi !instead of include 'mpif.h'
implicit none
integer :: tag,ierr,rank,numtasks,color,new_comm,inter1,inter2
integer :: sendbuf,recvbuf,stat(MPI_STATUS_SIZE)
integer :: irank
!
tag = 22
sendbuf = 222
!
call MPI_Init(ierr)
call MPI_COMM_RANK(MPI_COMM_WORLD,rank,ierr)
call MPI_COMM_SIZE(MPI_COMM_WORLD,numtasks,ierr)
!
if (rank < 2) then
color = 0
else
color = 1
end if
!
call MPI_COMM_SPLIT(MPI_COMM_WORLD,color,rank,new_comm,ierr)
!
if (color .eq. 0) then
call MPI_INTERCOMM_CREATE(new_comm,0,MPI_Comm_world,2,tag,inter1,ierr)
!
call MPI_COMM_RANK(inter1,irank,ierr)
if(irank==0)then
call mpi_send(sendbuf,1,MPI_INT,0,tag,inter1,ierr)
end if
!
else if(color .eq. 1) then
call MPI_INTERCOMM_CREATE(new_comm,0,MPI_COMM_WORLD,0,tag,inter2,ierr)
call MPI_COMM_RANK(inter2,irank,ierr)
if(irank==0)then
call mpi_recv(recvbuf,1,MPI_INT,0,tag,inter2,stat,ierr)
if(ierr/=MPI_SUCCESS)print*,'Error in rec '
print*,'rec buff = ', recvbuf
end if
end if
!
call MPI_finalize(ierr)
end program h
to me it seems that I am communicating between two different communicators: inter1 and inter2. Turning to the picture attached, I am communicating from comm1 towards comm2.
The picture is unrelated to the sample code.
Looking at the code, one rank MPI_Send(..., inter1, ...) and an other MPI_Recv(..., inter2, ...).
What matters here is how inter1 and inter2 were created, and they both come from all the ranks invoking MPI_Intercomm_create(), so even if you use different variable names, they indeed refer to the same (and unique) inter-communicator.
Here is a more intuitive way the program could have been written
use mpi !instead of include 'mpif.h'
implicit none
integer :: tag,ierr,rank,numtasks,color,new_comm,inter,remote_leader
integer :: sendbuf,recvbuf,stat(MPI_STATUS_SIZE)
integer :: irank
!
tag = 22
sendbuf = 222
!
call MPI_Init(ierr)
call MPI_COMM_RANK(MPI_COMM_WORLD,rank,ierr)
call MPI_COMM_SIZE(MPI_COMM_WORLD,numtasks,ierr)
!
if (rank < 2) then
color = 0
remote_leader=2
else
color = 1
remote_leader=0
end if
!
call MPI_COMM_SPLIT(MPI_COMM_WORLD,color,rank,new_comm,ierr)
!
call MPI_INTERCOMM_CREATE(new_comm,0,MPI_Comm_world,remote_leader,tag,inter,ierr)
call MPI_COMM_RANK(inter,irank,ierr)
if (irank.eq.0) then
if(color.eq.0) then
call mpi_send(sendbuf,1,MPI_INT,0,tag,inter,ierr)
else if(color.eq.1) then
call mpi_recv(recvbuf,1,MPI_INT,0,tag,inter,stat,ierr)
if(ierr/=MPI_SUCCESS)print*,'Error in rec '
print*,'rec buff = ', recvbuf
end if
end if
!
call MPI_finalize(ierr)
end program
Related
I'm writing a HDF5 wrapper subroutine that will read/write a double precision array of any shape from/to a dataset inside a HDF5 file. To achieve this, I use some C pointer trickery such that the subroutine takes in only the first element of the array as val, but it actually reads/writes the whole array using the temporary buffer buf(1:sz_buf).
So far I have the following for the read subroutine (after removing error checks to keep it concise):
SUBROUTINE hdf5_read_array_d( fname, path, name, val, dims )
USE ISO_C_BINDING, ONLY: C_SIZE_T, C_LOC, C_F_POINTER
! Input arguments
CHARACTER(LEN=*), INTENT(IN) :: fname, path, name
REAL(KIND(1.D0)), TARGET, INTENT(OUT) :: val
INTEGER, DIMENSION(:), INTENT(IN) :: dims
! Internal variables
INTEGER(KIND=HID_T) :: h5root, h5path, h5dset
INTEGER(KIND=HSIZE_T), DIMENSION(SIZE(dims)) :: h5dims
REAL(KIND(1.D0)), DIMENSION(:), POINTER :: buf
INTEGER(KIND=C_SIZE_T) :: sz_buf
INTEGER :: dim
! Open the file in read-only mode
CALL h5fopen_f( TRIM(fname), H5F_ACC_RDONLY_F, h5root, ierr )
! Open the pre-existing path in the file as a group
CALL h5gopen_f( h5root, TRIM(path), h5path, ierr )
! Open the dataset
CALL h5dopen_f( h5path, TRIM(name), h5dset, ierr )
! Convert dims to HSIZE_T
h5dims(:) = dims(:)
! C pointer trickery: cast double -> void* -> double*
sz_buf = PRODUCT(dims)
ALLOCATE( buf( sz_buf ) )
CALL C_F_POINTER( C_LOC(val), buf, (/sz_buf/) )
! Read data from dataset through buffer
CALL h5dread_f( h5dset, H5T_NATIVE_DOUBLE, buf, h5dims, ierr )
! Clean up and close HDF5 file
NULLIFY(buf)
CALL h5dclose_f( h5dset, ierr )
CALL h5gclose_f( h5path, ierr )
CALL h5fclose_f( h5root, ierr )
RETURN
END SUBROUTINE hdf5_read_array_d
Now, the question is, do I need to also put in DEALLOCATE(buf) in addition to / in place of the NULLIFY(buf)?
Any help would be appreciated.
Note: I am aware that Fortran 2018 includes assumed-rank arrays val(..) that will elegantly solve this problem. But again, it's a newer feature that might not be implemented by all compilers yet.
Edit: On C_F_POINTER(), here's a screenshot of Metcalf, Reid, and Cohen (4th Edition, not the newest one that has Fortran 2018 stuff):
You can use C-style pointer trickery to do what you want, but you have some things to address in your approach:
you have a memory leak with allocate(buf)
you are (subtly) lying about the scalar nature of val
you'll horribly confuse anyone reading your code
The reason why this is horribly confusing, is because you don't need to do this trickery. That's also why I won't show you how to do it, or to address the question "do I need to deallocate as well as nullify?".
You know that you have an array val to stuff n values in, in a contiguous lump. You worry that that can't do that because you (without using an assumed-rank dummy) have to match array shape. Worry not.
integer :: a(2,2,2,2), b(4,2,2), c(4,4)
are all arrays with 16 elements. So is
integer :: d(16)
You can associate actual arguments a, b and c with dummy argument d. Let's see that in action:
implicit none
integer :: a(2,2,2,2), b(4,2,2), c(4,4)
call set_them(a, SHAPE(a))
call set_them(b, SHAPE(b))
call set_them(c, SHAPE(c))
print '(16I3)', a, b, c
contains
subroutine set_them(d, dims)
integer, intent(in) :: dims(:)
integer, intent(out) :: d(PRODUCT(dims))
integer i
d=[(i,i=1,SIZE(d))]
end subroutine
end program
You can even associate array sections in this way to define portions.
You can see several other questions around here about this sequence association, in particular looking at changing shapes of arrays. This answer is more of a motivation of what to look for when tempted to do something complicated instead.
I have a commercial C library which I want to use with Fortran. There are two functions and a pointer struct like:
struct env;
typedef struct env *ENVptr;
the two functions have the prototype:
ENVptr open(int *status_p);
int close(ENVptr **env_p);
I wrote an Fortran interface to access them:
interface
function c_open(status) bind(c, name='c_open')
use, intrinsic :: iso_c_binding
integer(kind = c_int) :: status
type(c_ptr) :: c_open
end function
function c_close(env) bind(c, name='c_close')
use, intrinsic :: iso_c_binding
type(c_ptr) :: env
integer(kind = c_int) :: c_close
end function
end interface
I use this code to use this in my Fortran program:
type(c_ptr) :: env = c_null_ptr
env = c_open(status)
if ( status .ne. 0 ) then
print *, 'Could not open environment'
stop
end if
...some more code...
if ( c_associated(env) ) then
status = c_close(env)
if ( status .ne. 0 ) then
print *, 'Could not close environment.'
end if
end if
but when I execute the program, I get an Segmentation fault error when the program reaches the c_close function.
Is this the right way to interface the C routines?
I don't see how your program could have linked because the binding name of a procedure has to agree with the name in the actual C prototype. I suppose you could square the names up with a *.def file. Also Fortran has a concept of argument keywords so it is good practice in my opinion to make the Fortran dummy arguments in the interface agree with their documented argument names. Other than that you seem to have the right level of indirection in your interface bodies, so my version would be:
interface
function c_open(status_p) bind(C,name='open')
use, intrinsic :: iso_c_binding
implicit none
type(c_ptr) :: c_open
integer(kind = c_int) status_p
end function c_open
function c_close(env_p) bind(c,name='close')
use, intrinsic :: iso_c_binding
implicit none
integer(c_int) c_close
type(c_ptr) env_p
end function c_close
end interface
Now, there is a problem with the level of indirection when you invoke c_close because the C typedef for ENVptr already makes it a pointer, so ENVptr** envp is a pointer to a pointer to a pointer. In your Fortran code you are passing a c_ptr that points at an opaque type by reference, so you are passing a pointer to a pointer. Thus you need to create an extra level of indirection to make it fly. I would accordingly attempt to modify your code to something like:
type(c_ptr) :: env = c_null_ptr, envpp = c_null_ptr
target env
integer(c_int) status
env = c_open(status)
if ( status .ne. 0 ) then
print *, 'Could not open environment'
stop
end if
!...some more code...
if ( c_associated(env) ) then
envpp = c_loc(env)
status = c_close(envpp)
if ( status .ne. 0 ) then
print *, 'Could not close environment.'
end if
end if
I can't test this obviously but at this point it's syntactically correct and has the right level of indirection according to my reading of your problem statement.
I compiled my model code successfully, however it gives me this error when I try to run it:
forrtl: severe (408): fort: (8): Attempt to fetch from allocatable variable COS_ZENITH when it is not allocated.
I checked several questions and answers online but I'm not sure how I should handle this problem in my case. I think the error message seems quite clear but I don't have enough experience with fortran so I don't know if it's a bug or I have to modify the code etc.
This is the module of the code that apparently gives trouble:
MODULE mo_zenith
!
! Description:
! <Say what this module is for>
!
! Current Code Owner: <Name of person responsible for this code>
!
! History:
!
! Version Date Comment
! ------- ---- -------
! <version> <date> Original code. <Your name>
!
! Code Description:
! Language: Fortran 90.
! Software Standards: "European Standards for Writing and
! Documenting Exchangeable Fortran 90 Code".
!
! Modules used:
!
USE mo_mpi, ONLY: p_parallel_io, p_bcast, p_io
USE mo_kind, ONLY: dp
USE mo_io_units, ONLY: nout
USE mo_exception, ONLY: finish
USE mo_jsbach_grid , ONLY: domain_type
IMPLICIT NONE
PRIVATE
PUBLIC :: compute_orbit_and_solar, init_zenith, cos_zenith
REAL(dp), ALLOCATABLE, SAVE :: cos_zenith(:) !< Cosine of solar zenith angle for domain
LOGICAL :: module_configured = .FALSE.
LOGICAL :: module_initialized = .FALSE.
CONTAINS
SUBROUTINE compute_orbit_and_solar(domain)
! Compute orbital parameters for current time step
! Called from *jsbalone_driver* at the beginning of each time step
! If coupled with ECHAM:
! this is done in *pre_radiation* from *mo_radiation*, called in *scan1*
! the cosine of zenith angle is passed from ECHAM to the interface
! the interface copies the packed zenith angle to *cos_zenith*
USE mo_time_control, ONLY: l_orbvsop87, get_orbit_times
USE mo_orbit, ONLY: orbit_kepler, orbit_vsop87
USE mo_radiation_parameters, ONLY: nmonth,solar_parameters
TYPE(domain_type), INTENT(in) :: domain
LOGICAL :: l_rad_call = .FALSE.
LOGICAL :: lyr_perp = .FALSE. !< Switch to specify perpetual vsop87 year
INTEGER :: yr_perp = -99999 !< year if lyr_perp == .TRUE.
REAL(dp) :: rasc_sun, decl_sun, dist_sun, orbit_date, time_of_day
REAL(dp) :: flx_ratio, cos_mu0(domain%nland,1), daylght_frc(domain%nland,1)
REAL(dp), DIMENSION(domain%nland,1) :: sinlon, sinlat, coslon, coslat
INTEGER :: nland
nland = domain%nland
IF (.NOT. module_initialized) CALL init_zenith(domain)
CALL get_orbit_times(l_rad_call, lyr_perp, nmonth, yr_perp, time_of_day, orbit_date)
IF (l_orbvsop87) THEN
CALL orbit_vsop87 (orbit_date, rasc_sun, decl_sun, dist_sun)
ELSE
CALL orbit_kepler (orbit_date, rasc_sun, decl_sun, dist_sun)
END IF
sinlon(:,1) = domain%sinlon(1:nland)
sinlat(:,1) = domain%sinlat(1:nland)
coslon(:,1) = domain%coslon(1:nland)
coslat(:,1) = domain%coslat(1:nland)
CALL solar_parameters(decl_sun, dist_sun, time_of_day &
,sinlon, sinlat, coslon, coslat &
,flx_ratio, cos_mu0, daylght_frc)
cos_zenith(1:nland) = cos_mu0(1:nland,1)
END SUBROUTINE compute_orbit_and_solar
!
!=================================================================================================
SUBROUTINE init_zenith(domain)
! Pre-compute some work quantities for domain
TYPE(domain_type), INTENT(in) :: domain
IF (module_initialized) RETURN
ALLOCATE(cos_zenith(domain%nland))
module_initialized = .TRUE.
END SUBROUTINE init_zenith
END MODULE mo_zenith
any idea?
Thank you in advance!
I have a subroutine that I would like to be called recursively, but it seems that there is a memory leak when calling it. I've already posted questions on memory leaks in functions
Fortran 90 function return pointer
Fortran 90 difference between compaq visual fortran and gfortran
but now I have a new problem. I've switched all of my functions to subroutines, and now I'm having trouble with calling a subroutine recursively. Here is my code (sorry it's not short)
recursive subroutine myCurl3DRTest(d3,u,v,w,gd,n)
implicit none
type(vecField3D),intent(inout) :: d3
real(dpn),dimension(:,:,:),intent(in) :: u,v,w
type(griddata),intent(in) :: gd
integer,intent(in),optional :: n
type(vecField3D) :: temp1,temp2,temp3,temp4,temp5,temp6
real(dpn),dimension(:,:,:),allocatable :: dwdy,dvdz
real(dpn),dimension(:,:,:),allocatable :: dwdx,dudz
real(dpn),dimension(:,:,:),allocatable :: dvdx,dudy
real(dpn),dimension(:,:,:),allocatable :: curlx,curly,curlz
integer :: dummyN
integer,dimension(3) :: s
s = shape(u)
if (.not.present(n)) then
dummyN = 1
else ; dummyN = n ;endif
call nullifyField(temp1)
call nullifyField(temp2)
call nullifyField(temp3)
call nullifyField(temp4)
call nullifyField(temp5)
call nullifyField(temp6)
call myDel(temp1,w,gd,1,2)
call myDel(temp2,v,gd,1,3)
call myDel(temp3,w,gd,1,1)
call myDel(temp4,u,gd,1,3)
call myDel(temp5,v,gd,1,1)
call myDel(temp6,u,gd,1,2)
allocate(dwdy(s(1),s(2),s(3)))
allocate(dvdz(s(1),s(2),s(3)))
allocate(dwdx(s(1),s(2),s(3)))
allocate(dudz(s(1),s(2),s(3)))
allocate(dvdx(s(1),s(2),s(3)))
allocate(dudy(s(1),s(2),s(3)))
call getY(temp1,dwdy)
call getZ(temp2,dvdz)
call getX(temp3,dwdx)
call getZ(temp4,dudz)
call getX(temp5,dvdx)
call getY(temp6,dudy)
call deleteField(temp1)
call deleteField(temp2)
call deleteField(temp3)
call deleteField(temp4)
call deleteField(temp5)
call deleteField(temp6)
call setX(d3, dwdy - dvdz )
call setY(d3,-( dwdx - dudz ))
call setZ(d3, dvdx - dudy )
deallocate(dwdy)
deallocate(dvdz)
deallocate(dwdx)
deallocate(dudz)
deallocate(dvdx)
deallocate(dudy)
allocate(curlx(s(1),s(2),s(3)))
allocate(curly(s(1),s(2),s(3)))
allocate(curlz(s(1),s(2),s(3)))
call getX(d3,curlx)
call getY(d3,curly)
call getZ(d3,curlz)
if (dummyN.gt.1) then
call myCurl3DRTest(d3,curlx,curly,curlz,gd,dummyN-1)
endif
deallocate(curlx)
deallocate(curly)
deallocate(curlz)
end subroutine
And in the main program, I have
do k=1,10**4
call myCurl3DRTest(f3,u,v,w,gd,1)
! call myCurl(f3,u,v,w,gd)
enddo
This, as I mentioned in my previous questions about memory leaks, is causing a memory leak too. Is there something I'm forgetting to allocate? Or are the curlx, curly and curlz not getting deallocated from each level?
Just so it's clear, inside deleteField:
subroutine deleteField(this)
implicit none
type(vecField3D),intent(inout) :: this
if (associated(this%x)) deallocate(this%x)
if (associated(this%y)) deallocate(this%y)
if (associated(this%z)) deallocate(this%z)
this%TFx = .false.
this%TFy = .false.
this%TFz = .false.
end subroutine
and inside nullifyField:
subroutine nullifyField(this)
implicit none
type(vecField3D),intent(inout) :: this
nullify(this%x); this%TFx = .false.
nullify(this%y); this%TFy = .false.
nullify(this%z); this%TFz = .false.
this%TFNullified = .true.
end subroutine
Any help is greatly appreciated!
I'm guessing based on your previous posts that in your setX (and similar) procedures that you allocate some pointer components of the d3 object passed as the first argument. I don't see how those pointer allocations could be matched by a deallocate before the next iteration of the loop or before the nested call to myCurl3DRTest. Depending on what you are trying to do those deallocations could perhaps be provided by calls to nullifyField.
If my guess is right then without those deallocations, you would have a memory leak.
A language level of Fortran 95 plus the allocatable TR would make your life so much easier...
I have a code like this
:
procedure(),pointer :: p
if ()
p => job1
else
p => job2
endif
do i=1,a_big_number
call x(...)
call p(i,j,k)
enddo
The subroutine 'job1' does some work, but the subroutine 'job2' does nothing. In other words, under some circumstances, I need to finish 'x' and 'job1'. Under other circumstances, I only need to do 'x'. My question is how should I define job2. It seems simply using null() does not work. What I am doing right now is like:
subroutine job2(i,j,k)
integer,intent(in) :: i,j,k
end subroutine
However, this looks silly, and I got a lot compiling warning when I compiled the code because those arguments were not used. Is there a smarter way to do this?
You could nullify the procedure pointer in the case that there was nothing useful to do, and then test the association status prior to invoking the procedure through the pointer.
PROCEDURE(interface_that_matches_job1), POINTER :: p
IF (...) THEN
p => job1
ELSE
NULLIFY(p) ! Or p => NULL()
END IF
DO i = 1, a_big_number
CALL x(...)
IF (ASSOCIATED(p)) CALL p(i,j,k)
END DO
If your concern is really about the if statement in the loop, you could just put the if statement outside of the loop:
if (condition) then
do ii = 1, big_number
call x(...)
call p(i,j,k)
end do
else
do ii = 1, big_number
call x(...)
end do
end if
Then do some timings on this version and then on a version with the if inside the loop:
do ii = 1, big_number
call x(...)
if (condition) then
call p(i,j,k)
end if
end do
I'd rather guess that you won't see any significant difference between them, as the subroutine call in the loop may already giving you an overhead much larger as the one caused by the if statement.