I'm trying to compile and run a relatively old code from a PhD thesis, you can find whole code in Appendices C and D of this document.
Here is necessary parts from the code:
from wfMath.f90 :
subroutine wfmath_gaussian(widthz,pz)
use progvars
implicit none
real*8, intent(in) :: widthz ! the width of the wavepacket
real*8, intent(in) :: pz ! momentum
integer :: nR
real*8 :: rvalue
complex*16 :: cvalue
! complex*16 :: psi !!!ORIGINAL CODE LINE 23/02/2018. Saba
complex*16, dimension(1) :: psi !!! psi is originally defined as a scalar. But wfmath_normalize(wf) takes a rank-1 tensor as
!argument. So here I change the declaration of psi from a scalar to a rank-1 tensor contains only one element. 23/02/2018. Saba
real*8 :: z2
z2 = minz + deltaz
do nR=1, nz
rvalue = exp( -((z2-centerz)/widthz)**2 /2 )/ (2*pi*widthz) !!!ORIGINAL CODE LINE
!rvalue = exp( -((z2-centerz)/1.0d0)**2 /2 )/ (2*pi*1.0d0)
cvalue = cdexp( cmplx(0.0,1.0)*(pz*z2))
psi(nR) = rvalue * cvalue
z2 = z2 + deltaz ! next grid position in x-direction
enddo
call wfmath_normalize(psi)
end subroutine wfmath_gaussian
from tdse.f90 - main part :
subroutine init
use progvars
use strings;
use wfMath;
use wfPot;
!use tdseMethods;
implicit none
integer :: nloop
real*8 :: widthz,pz
select case (trim(molecule))
case("H2")
mass = 917.66d0; nz = 2048; deltaz = 0.05d0;
case("D2")
mass = 1835.241507d0; nz = 1024; deltaz = 0.05d0;
case("N2")
mass = 12846.69099d0; nz = 512; deltaz = 0.01d0;
case("O2")
mass = 14681.93206d0; nz =8192 ; deltaz = 0.005d0;
case("Ar2")
mass = 36447.94123d0; nz = 65536; deltaz = 0.002d0;
end select
maxt = 33072.80d0 !800fs ! maximum time
deltat = 1.0d0 ! delta time
widthz = 1.0d0 ! width of the gaussian
minz = 0.05d0 ! minimum z in a.u.
maxz = nz * deltaz ! maximum z in a.u.
centerz = 2.1d0 ! center of the gaussian
nt = NINT(maxt/deltat) ! time steps
pz = 0.d0 ! not used currently
!_____________________________FFT Section____________________________________________
deltafft = 20.d0* deltat !1.0d0*deltat ! time step for FFT
nfft = NINT(maxt/deltafft) ! no of steps for FFT
!_________________________absorber parameters_______________________________________
fadewidth = 10.d0 ! the width of the absorber in a.u.
fadestrength = 0.01d0 ! the maximum heigth of the negative imaginary potential
!_________________________E FIELD section_____________________________________________
Ewidth = 1446.2d0 !35fs ! width of the envelope
Eo = 0.053 !E14 ! field amplitude
Eomega = 0.057d0 !800nm ! laser frequency
! Eomega = 0.033d0 !1400nm ! laser frequency
Ephi = 0.d0 ! carrier envelope phase
Eto = 1000.d0 ! ecenter of the Gaussian envelope
EoPed = 0.0755 !2E14
EwidthPed = 826.638 !20fs
EomegaPed = Eomega
EphiPed = 0.d0
EtoPed = 1000.d0
EoPump = 0.053 !1E14 0.00285d0
EwidthPump = Ewidth
EomegaPump = 0.057d0
EphiPump = 0.0d0
EtoPump = 0.d0
includeAbsorber = .true. ! switch for absorber
includeField = .true. ! .false. ! switch for efield
includePedestal = .false. ! switch for pedestal
includeConstantPump = .true. ! .false. ! switch for efield
useADK = .false. ! ADK switch
calculatePowerSpectra = .true.
calculateKERPowerSpectra = .true. !.false.
!_____________________________Printing & Plotting Filters__________________________________
printFilter = nz
maxFrequencyFilter = 500
printInterval =100 !200
! print filter upper boundary check
if(printFilter > nz) then
printFilter = nz
end if
call allocateArrays();
do nloop = 1,nz
Z(nloop) = minz+ (nloop)* deltaz;
P(nloop) = 2*pi*(nloop-(nz/2)-1)/(maxz-minz);
E(nloop) = 27.2*(P(nloop)**2)/(4.d0*mass);
end do
! call wfmath_gaussian(psiground,widthz,pz) !!! ORIGINAL CODE LINE
call wfmath_gaussian(psiground,real(widthz),pz) ! Attempt to solve mismatch error. Does not work. Saba 24/02/2018
! call wfmath_gaussian(psiground,1.0d0,pz) ! Attempt to solve mismatch error. Does not work. Saba 23/02/2018
! call wfmath_gaussian(pz) ! Attempt to solve mismatch error. Does not work. Saba 23/02/2018
call setabsorber_right(fadewidth, fadestrength)
call printpsi(psiground,trim(concat(outputFolder,"psi_gausssian.dat")))
call potentials_init(nz) !initialize potential arrays
call read_potential();
end subroutine init
As far as I understand, there is no mismatch at all. widthz is declared as real*8 in main part of the code (subroutine init), and subroutine wfmath_gaussian(...) expects widthz to be a real*8. I can't see where this mismatch error occurs?
used compiler: GNU Fortran 6.3.0
used compile line: $gfortran tdse.f90
error message:
tdse.f90:159:118:
call wfmath_gaussian(psiground,real(widthz),pz) ! Attempt to solve mismatch error. Does not work. Saba 24/02/2018
(1)
Error: Type mismatch in argument 'widthz' at (1); passed COMPLEX(8) to REAL(8)
Thanks in advance...
I now want to use the allgather to rebuild a 3D array. 16 cups are claimed and the data of the Y-Z plane are partitioned into 4*4 parts.
Also a new type (newtype) is created for convenience.
Are the errors related to this new type, Thanks!
!==================================================================================================================================
!****** [ Program main ] ********************************************************************************************************
!==================================================================================================================================
program main
Use mpi
implicit none
integer i, j, k, count, realsize
integer, parameter :: nx = 8, ny = 8, nz = 8
Integer :: interval
real(4), dimension(nx,ny,nz):: u_xyz
Real(4),dimension(:,:,:), allocatable :: Temp0
! === MPI Related ===
Integer, Parameter :: master = 0
Integer :: ierr, num_procs, myid, p_row, p_col, newtype, resizedtype
integer, save :: MPI_COMM_CART
integer, dimension(2) :: dims, coord
Integer, Dimension(2) :: R_coord, C_coord, MPGD
Integer, Dimension(3) :: sizes, subsizes, starts
integer,dimension(:),allocatable :: displacement
integer(kind=mpi_address_kind) :: lb, extent
logical, dimension(2) :: periodic
!--------------=======--------------
! Initialize MPI
!
call MPI_Init ( ierr )
!
! Get the number of processes.
!
call MPI_Comm_size ( MPI_COMM_WORLD, num_procs, ierr )
!
! Get the individual process ID.
!
call MPI_Comm_rank ( MPI_COMM_WORLD, myid, ierr )
!--------------=======--------------
! Y-Z PLANE SPLIT
!--------------=======--------------
p_row = 4; p_col = 4
If(p_row*p_col .NE. num_procs) Print *, 'Wrong CPU Numbers'
!--------------=======--------------
dims(1) = p_row
dims(2) = p_col
periodic(1) = .false.
periodic(2) = .false.
call MPI_CART_CREATE(MPI_COMM_WORLD,2,dims,periodic, &
.false., & ! do not reorder rank
MPI_COMM_CART, ierr)
call MPI_CART_COORDS(MPI_COMM_CART,myid,2,coord,ierr)
!--------------=======--------------
!----------YZ Plane Locations-----
!--------------=======--------------
Interval = Ceiling(dble(ny)/dble(p_row))
If (coord(1) .NE. p_row-1 ) then
R_coord(1) = 1 + (coord(1))*Interval
R_coord(2) = R_coord(1) + Interval - 1
Else
R_coord(1) = 1 + coord(1)*Interval
R_coord(2) = ny
End If
Interval = Ceiling(dble(nz)/dble(p_col))
If (coord(2) .NE. p_col-1 ) then
C_coord(1) = 1 + (coord(2))*Interval
C_coord(2) = C_coord(1) + Interval - 1
Else
C_coord(1) = 1 + (coord(2))*Interval
C_coord(2) = nz
End If
!--------------=======--------------
!----------Obtain displacement-----
!--------------=======--------------
! COUNT = 0
! DO K=1,nz
! DO J=1,ny
! DO I=1,nx
! If(i==1.and.j== R_coord(1).and.k==C_coord(1)) print *, myid, R_coord(1), C_coord(1), COUNT
! COUNT = COUNT + 1
! ENDDO
! ENDDO
! ENDDO
allocate(Temp0(nx,R_coord(1):R_coord(2),C_coord(1):C_coord(2)))!
allocate(displacement(num_procs))
Do k=C_coord(1),C_coord(2)
Do j=R_coord(1),R_coord(2)
Do i=1,nx
u_xyz(i,j,k)= i+j+k
End Do; End Do
End Do
Do i=0,num_procs-1
displacement(i)= (i/4)*(16) + mod(i,4)*128
! if(myid==0) print *, i, displacement(i)
Enddo
!--------------=======--------------
! --- Create the same block type ---
!--------------=======--------------
sizes(1) = nx
sizes(2) = ny
sizes(3) = nz
subsizes(1) = nx
subsizes(2) = R_coord(2)-R_coord(1)+1
subsizes(3) = C_coord(2)-C_coord(1)+1
starts(1) = 0 ! 0-based index
starts(2) = 0
starts(3) = 0
call MPI_TYPE_CREATE_SUBARRAY(3, sizes, subsizes, starts, &
MPI_ORDER_FORTRAN, MPI_REAL, newtype, ierr)
call MPI_Type_size(MPI_REAL, realsize, ierr)
extent = 1*realsize
lb = 0
call MPI_Type_create_resized(newtype, lb, extent, resizedtype, ierr)
call MPI_Type_commit(resizedtype, ierr)
Call MPI_Allgather(Temp0(1,R_coord(1),C_coord(1)),resizedtype, &
1, u_xyz, resizedtype, displacement, &
1, MPI_COMM_WORLD)
call MPI_TYPE_FREE(newtype,ierr)
777 Format(15e25.16e3)
Call MPI_Barrier(MPI_COMM_WORLD, ierr)
Call MPI_Finalize ( ierr )
stop
end program main
The code had some error messages as follows:
[desktop:18885] *** An error occurred in MPI_Allgather
[desktop:18885] *** reported by process [139648622723073,139646566662149]
[desktop:18885] *** on communicator MPI_COMM_SELF
[desktop:18885] *** MPI_ERR_TYPE: invalid datatype
[desktop:18885] *** MPI_ERRORS_ARE_FATAL (processes in this communicator will now abort,
[desktop:18885] *** and potentially your MPI job)
-------------------------------------------------------
Primary job terminated normally, but 1 process returned
a non-zero exit code.. Per user-direction, the job has been aborted.
-------------------------------------------------------
--------------------------------------------------------------------------
mpirun detected that one or more processes exited with non-zero status, thus causing
the job to be terminated. The first process to do so was:
Process name: [[31373,1],0]
Exit code: 3
--------------------------------------------------------------------------
[desktop:18878] 7 more processes have sent help message help-mpi-errors.txt / mpi_errors_are_fatal
[desktop:18878] Set MCA parameter "orte_base_help_aggregate" to 0 to see all help / error messages
The correct code. Thanks to the comments above. Care should be taken when defining the type, such as.
recvcounts
integer array (of length group size) containing the number of elements that are to be received from each process
displs
integer array (of length group size). Entry i specifies the displacement (relative to recvbuf ) at which to place the incoming
data from process i recvtype
!==================================================================================================================================
!****** [ Program main ] ********************************************************************************************************
!==================================================================================================================================
program main
Use mpi
implicit none
integer i, j, k,ii
integer count, realsize
integer, parameter :: nx = 8, ny = 8, nz = 8
Integer :: interval
real(4), dimension(nx*ny*nz):: u_xyz
Real(4),dimension(:,:,:), allocatable :: Temp0
! === MPI Related ===
Integer, Parameter :: master = 0
Integer :: ierr, num_procs, myid, p_row, p_col, newtype, resizedsd, resizedrv
integer, save :: MPI_COMM_CART
integer, dimension(2) :: dims, coord
Integer, Dimension(2) :: R_coord, C_coord, MPGD
Integer, Dimension(3) :: sizes, subsizes, starts
integer,dimension(:),allocatable :: displacement, recvcnt
integer(kind=mpi_address_kind) :: lb, extent
logical, dimension(2) :: periodic
!--------------=======--------------
! Initialize MPI
!
call MPI_Init ( ierr )
!
! Get the number of processes.
!
call MPI_Comm_size ( MPI_COMM_WORLD, num_procs, ierr )
!
! Get the individual process ID.
!
call MPI_Comm_rank ( MPI_COMM_WORLD, myid, ierr )
!--------------=======--------------
! Y-Z PLANE SPLIT
!--------------=======--------------
p_row = 4; p_col = 4
If(p_row*p_col .NE. num_procs) Print *, 'Wrong CPU Numbers'
!--------------=======--------------
dims(1) = p_row
dims(2) = p_col
periodic(1) = .false.
periodic(2) = .false.
call MPI_CART_CREATE(MPI_COMM_WORLD,2,dims,periodic, &
.false., & ! do not reorder rank
MPI_COMM_CART, ierr)
call MPI_CART_COORDS(MPI_COMM_CART,myid,2,coord,ierr)
!--------------=======--------------
!----------YZ Plane Locations-----
!--------------=======--------------
Interval = Ceiling(dble(ny)/dble(p_row))
If (coord(1) .NE. p_row-1 ) then
R_coord(1) = 1 + (coord(1))*Interval
R_coord(2) = R_coord(1) + Interval - 1
Else
R_coord(1) = 1 + coord(1)*Interval
R_coord(2) = ny
End If
Interval = Ceiling(dble(nz)/dble(p_col))
If (coord(2) .NE. p_col-1 ) then
C_coord(1) = 1 + (coord(2))*Interval
C_coord(2) = C_coord(1) + Interval - 1
Else
C_coord(1) = 1 + (coord(2))*Interval
C_coord(2) = nz
End If
!--------------=======--------------
!----------Obtain displacement-----
!--------------=======--------------
! COUNT = 0
! DO K=1,nz
! DO J=1,ny
! DO I=1,nx
! If(i==1.and.j== R_coord(1).and.k==C_coord(1)) print *, myid, R_coord(1), C_coord(1), COUNT
! COUNT = COUNT + 1
! ENDDO
! ENDDO
! ENDDO
allocate(Temp0(1:nx,R_coord(1):R_coord(2),C_coord(1):C_coord(2)))!
allocate(displacement(num_procs),recvcnt(num_procs))
Do k=C_coord(1),C_coord(2)
Do j=R_coord(1),R_coord(2)
Do i=1,nx
Temp0(i,j,k)= i+j*10+k*100
End Do; End Do
End Do
Do i=1,num_procs
ii = i-1
displacement(i)= (ii/4)*(16) + mod(ii,4)*128
! if(myid==0) print *, i, displacement(i)
Enddo
!--------------=======--------------
! --- Create the same block type ---
!--------------=======--------------
sizes(1) = nx
sizes(2) = ny
sizes(3) = nz
subsizes(1) = nx
subsizes(2) = R_coord(2)-R_coord(1)+1
subsizes(3) = C_coord(2)-C_coord(1)+1
starts(1) = 0 ! 0-based index
starts(2) = 0
starts(3) = 0
recvcnt(:)= 1
call MPI_TYPE_CREATE_SUBARRAY(3, sizes, subsizes, starts, &
MPI_ORDER_FORTRAN, MPI_REAL, newtype, ierr)
call MPI_Type_size(MPI_REAL, realsize, ierr)
extent = 1*realsize
lb = 0
call MPI_Type_create_resized(newtype, lb, extent, resizedrv, ierr)
call MPI_Type_commit(resizedrv, ierr)
Call MPI_AllgatherV(Temp0(1,R_coord(1),C_coord(1)), subsizes(1)*subsizes(2)*subsizes(3), MPI_REAL, &
u_xyz, recvcnt,displacement, resizedrv, MPI_COMM_WORLD, ierr)
call MPI_TYPE_FREE(resizedrv,ierr)
! If(myid.eq.10) then
! Count = 0
! do k=1,nz
! do J=1,ny
! do i=1,nx
! Count = Count + 1
! print*, u_xyz(count)- (i+j*10+k*100), i,j,k
! enddo; enddo; enddo
! end if
777 Format(15e25.16e3)
Call MPI_Barrier(MPI_COMM_WORLD, ierr)
Call MPI_Finalize ( ierr )
stop
end program main