! file: point_source.f90 ! author: Sam Adams and Jason Payne ! date: 20060510 - arbitrary pulse added ! 20050923 - file created ! discription: implementation of a point source instead of an incident field module ps_parameters ! XXX adding point source global variables here. Note: in fortran ! 90/95 common is deprecated; however, I am just trying to follow the existing code integer, dimension(3) :: psLocation ! (x,y,z) integer :: psOrientation, psType real :: psAmplitude, n0, nDecay common /psCommon/ psLocation, psOrientation, psAmplitude, n0, nDecay, psType real, allocatable, dimension(:) :: arbPulse end module ps_parameters function getNextE() use ps_parameters implicit none real getNextE getNextE = 2.0 return end function ! expects root to send to all children subroutine sendInt(a_int) use commona implicit none integer a_int, i, pass_me pass_me = a_int do i = 1, np-1 write(*,*)"--sending ", pass_me, " to ", i call MPI_Send(pass_me, 1, MPI_INTEGER, i, MPI_COMM_WORLD, ierr) end do end subroutine ! expects root to send to all children subroutine sendReal(a_real) use commona implicit none real :: a_real, pass_me integer :: i pass_me = a_real do i = 1, np-1 write(*,*)"--sending ", pass_me, " to ", i call MPI_Send(pass_me, 1, MPI_REAL, i, MPI_COMM_WORLD, ierr) end do end subroutine subroutine readArbPulseFile(fileName) use ps_parameters use commona use aitoc implicit none character*40 :: fileName integer :: ioUnit = 101 integer :: returnStatus, i real, dimension(10) :: r_arr = (/ (i, i=1,10) /) open(unit=ioUnit, file=fileName, status="old", iostat=returnStatus, form="formatted", action="read") if(returnStatus.ne.0) then write(*,*)"error: could not open file ", fileName, " (error ", returnStatus, ")" write(*,*)" -killing processors" call sendInt(-2) write(*,*)" -aborting" call MPI_Abort(MPI_COMM_WORLD, ierr) end if call sendInt(0) do i = 1, 10 call sendReal(r_arr(i)) end do write(*,*)"everything was good with the root." end subroutine subroutine getArbPulseArray() use ps_parameters use commona use aitoc implicit none integer :: pulseStatus, mpiStatus, i real, dimension(10) :: r_arr real :: real1, real2, real3 write(*,*)"checking for a pulse... array that is!" call MPI_Recv(pulseStatus, 1, MPI_INTEGER, 0, 0, MPI_COMM_WORLD, mpiStatus, ierr) write(*,*)" -0 got ", pulseStatus, " my rank ", my_rank if(pulseStatus.eq.-2) then write(*,*)" -no pulse found! Abort!" call MPI_Abort(MPI_COMM_WORLD, ierr) else if(pulseStatus.eq.-1) then write(*,*)" -not an arbitrary pulse problem" else if(pulseStatus.eq.0) then write(*,*)" -getting pulse array" call MPI_Recv(real1, 1, MPI_REAL, 0, 0, MPI_COMM_WORLD, mpiStatus, ierr) write(*,*)" -1 got ", real1, " my rank ", my_rank, " ierror = ", ierr call MPI_Recv(real2, 1, MPI_REAL, 0, 0, MPI_COMM_WORLD, mpiStatus, ierr) write(*,*)" -2 got ",real2, " my rank ", my_rank, " ierror = ", ierr call MPI_Recv(real3, 1, MPI_REAL, 0, 0, MPI_COMM_WORLD, mpiStatus, ierr) write(*,*)" -3 got ", real3, " my rank ", my_rank, " ierror = ", ierr call MPI_Recv(r_arr(4), 1, MPI_REAL, 0, 0, MPI_COMM_WORLD, mpiStatus, ierr) write(*,*)" -4 got ", r_arr(4), " my rank ", my_rank, " ierror = ", ierr call MPI_Recv(r_arr(5), 1, MPI_REAL, 0, 0, MPI_COMM_WORLD, mpiStatus, ierr) write(*,*)" -5 got ", r_arr(5), " my rank ", my_rank, " ierror = ", ierr call MPI_Recv(r_arr(6), 1, MPI_REAL, 0, 0, MPI_COMM_WORLD, mpiStatus, ierr) write(*,*)" -6 got ", r_arr(6), " my rank ", my_rank, " ierror = ", ierr call MPI_Recv(r_arr(7), 1, MPI_REAL, 0, 0, MPI_COMM_WORLD, mpiStatus, ierr) write(*,*)" -7 got ", r_arr(7), " my rank ", my_rank, " ierror = ", ierr call MPI_Recv(r_arr(8), 1, MPI_REAL, 0, 0, MPI_COMM_WORLD, mpiStatus, ierr) write(*,*)" -8 got ", r_arr(8), " my rank ", my_rank, " ierror = ", ierr call MPI_Recv(r_arr(9), 1, MPI_REAL, 0, 0, MPI_COMM_WORLD, mpiStatus, ierr) write(*,*)" -9 got ", r_arr(9), " my rank ", my_rank, " ierror = ", ierr call MPI_Recv(r_arr(10), 1, MPI_REAL, 0, 0, MPI_COMM_WORLD, mpiStatus, ierr) write(*,*)" -10 got ", r_arr(10), " my rank ", my_rank, " ierror = ", ierr else write(*,*)" -unexpected status. Abort!" call MPI_Abort(MPI_COMM_WORLD, ierr) end if write(*,*)"everything was good with the node", my_rank end subroutine function get_ifield_descrip_ps() implicit none character*20 get_ifield_descrip_ps get_ifield_descrip_ps = 'point_source' return end function get_ifield_descrip_ps subroutine read_ifield_param_ps(iunit) use ps_parameters use incident_field implicit none integer iunit, ierr, i character*40 fileName ! character*20 tmpType ! of source pulse ! character tmpOrientation read(iunit,11,err=22,end=21) psLocation(0) read(iunit,11,err=22,end=21) psLocation(1) read(iunit,11,err=22,end=21) psLocation(2) read(iunit,10,err=22,end=21) psAmplitude read(iunit,11,err=22,end=21) psOrientation read(iunit,11,err=22,end=21) psType ! psType (0 == sinusoidal, 1 == gaussian, 2 == arbitrary) if(psType.eq.1) then read(iunit,10,err=22,end=21) n0 read(iunit,10,err=22,end=21) nDecay call sendInt(-1) else if(psType.eq.2) then read(iunit,15,err=22,end=21) fileName call readArbPulseFile(fileName) end if write(*,*)"at the end of read_ifield_param_ps, my rank ", my_rank return 21 write(*,*) 'Encountered unexpected EOF in point source parameter file. ' call abort_processes() 22 write(*,*) 'Read error in point source parameter file. ' call abort_processes() 10 format (d10.0) 11 format (i10) 15 format (a40) end subroutine read_ifield_param_ps subroutine pass_ifield_param_ps() use ps_parameters use incident_field implicit none integer arraySize double precision array(8) arraySize = 6 if(psType.eq.1) then arraySize = arraySize + 2 end if ! Store parameters in message passing arrays. array(1) = psLocation(0) array(2) = psLocation(1) array(3) = psLocation(2) array(4) = psAmplitude array(5) = psOrientation array(6) = psType if(psType.eq.1) then array(7) = n0 array(8) = nDecay end if ! Pass array to all processors. call pass_double_array(array,8) ! Then assign the values from above: psLocation(0) = array(1) psLocation(1) = array(2) psLocation(2) = array(3) psAmplitude = array(4) psOrientation = array(5) psType = array(6) if(psType.eq.1) then n0 = array(7) nDecay = array(8) end if return end subroutine pass_ifield_param_ps subroutine dump_ifield_param_ps(iunit) use ps_parameters implicit none integer iunit write (iunit,*) 'psLocation X ',psLocation(0) write (iunit,*) 'psLocation Y ',psLocation(1) write (iunit,*) 'psLocation Z ',psLocation(2) write (iunit,*) 'psAmplitude ',psAmplitude write (iunit,*) 'psOrientation ',psOrientation write (iunit,*) "psType ",psType if(psType.eq.1) then write (iunit,*) "n0 ",n0 write (iunit,*) "nDecay ",nDecay end if end subroutine dump_ifield_param_ps subroutine list_ifield_param_ps(iunit) use ps_parameters implicit none integer iunit write (iunit,*) 'Point source parameters:' write (iunit,*) 'psLocation X ',psLocation(0) write (iunit,*) 'psLocation Y ',psLocation(1) write (iunit,*) 'psLocation Z ',psLocation(2) write (iunit,*) 'psAmplitude ',psAmplitude write (iunit,*) 'psOrientation ',psOrientation write (iunit,*) "psType ",psType return end subroutine list_ifield_param_ps ! I am assuming that regular encode_log_file_name function is ! good enough for a ps as well as a pw, so this function is not ! called anywhere, and I left the rest of the main code to just use ! the function in the pw code function encode_log_file_name_ps() use commona use aitoc use incident_field implicit none character*200 encode_log_file_name_ps encode_log_file_name_ps = "ps" return end function encode_log_file_name_ps