mirror of
https://code.it4i.cz/sccs/easyconfigs-it4i.git
synced 2025-04-15 19:28:06 +01:00
242 lines
7.4 KiB
Fortran
Executable File
242 lines
7.4 KiB
Fortran
Executable File
!mpifort -o mrcc_manager signal.o cfunc.o combin.f manager.f90 manager_main.f90 -i8 -traceback -g -DMPI -DOPENMPI -mkl=parallel -cpp -debug
|
|
!mpifort -o mrcc_manager signal.o cfunc.o combin.o manager.f90 manager_main.f90 -i8 -traceback -g -DMPI -DOPENMPI -mkl=parallel -cpp
|
|
#if defined(MPI)
|
|
program manager_program
|
|
!DEC$ NOOPTIMIZE
|
|
use manager
|
|
!use mpi
|
|
implicit none
|
|
|
|
include "mpif.h"
|
|
integer :: message
|
|
integer :: parent_comm, error
|
|
integer, parameter :: MAX_COUNTERS = 128
|
|
integer :: counters(MAX_COUNTERS), ncounter
|
|
integer :: manager_comm
|
|
logical :: flag, plen
|
|
integer :: msg_status(MPI_STATUS_SIZE), provided
|
|
integer :: i
|
|
character(len=MPI_MAX_PROCESSOR_NAME) :: pname
|
|
logical :: counter_allocated(MAX_COUNTERS)
|
|
|
|
|
|
#ifdef DEBUG
|
|
write(*,*) 'DEBUG: Manager running'
|
|
#endif
|
|
|
|
call addPidToList
|
|
|
|
call MPI_Init_thread(MPI_THREAD_SINGLE, provided, error)
|
|
|
|
call MPI_Comm_get_parent(parent_comm, error)
|
|
if(parent_comm == MPI_COMM_NULL) call exit(0)
|
|
|
|
counters = 1
|
|
counter_allocated = .false.
|
|
|
|
! open(1, file='manager.out')
|
|
|
|
call MPI_Get_processor_name(pname, plen, error)
|
|
! write(6, *) pname
|
|
|
|
outer: do
|
|
do
|
|
call MPI_Iprobe(MPI_ANY_SOURCE, MPI_ANY_TAG, parent_comm, flag, msg_status, error)
|
|
if(.not.flag) exit
|
|
|
|
! write(6, '(a,3i5)') 'msg src tag ',message, msg_status(MPI_SOURCE), msg_status(MPI_TAG)
|
|
|
|
select case (msg_status(MPI_TAG))
|
|
case (REQ_EXIT)
|
|
#ifdef DEBUG
|
|
write(*,*) 'DEBUG: Manager exiting'
|
|
#endif
|
|
call MPI_Recv(message, 1, MPI_INTEGER_MRCC, msg_status(MPI_SOURCE), msg_status(MPI_TAG), parent_comm, msg_status, error)
|
|
exit outer
|
|
|
|
case (REQ_SENDCOUNTER)
|
|
#ifdef DEBUG
|
|
write(*,*) 'DEBUG: Manager sending counter'
|
|
#endif
|
|
call MPI_Recv(ncounter, 1, MPI_INTEGER_MRCC, msg_status(MPI_SOURCE), msg_status(MPI_TAG), parent_comm, msg_status, error)
|
|
call MPI_Recv(message, 1, MPI_INTEGER_MRCC, msg_status(MPI_SOURCE), msg_status(MPI_TAG), parent_comm, msg_status, error)
|
|
! send current value of counter and increment it according to message
|
|
! write(6, *) 'sending ', counters(ncounter), ' to ', msg_status(MPI_SOURCE)
|
|
#ifdef DEBUG
|
|
write(*,*) 'DEBUG: Manager sending counter ', ncounter
|
|
#endif
|
|
call send_increment_counter(counters(ncounter), message, msg_status(MPI_SOURCE), parent_comm)
|
|
! call MPI_Send(counters(ncounter), 1, MPI_INTEGER_MRCC, msg_status(MPI_SOURCE), 1, parent_comm, error)
|
|
! counters(ncounter) = counters(ncounter) + message
|
|
|
|
case (REQ_RESETCOUNTER)
|
|
#ifdef DEBUG
|
|
write(*,*) 'DEBUG: Manager resetting counter'
|
|
#endif
|
|
call MPI_Recv(message, 1, MPI_INTEGER_MRCC, msg_status(MPI_SOURCE), msg_status(MPI_TAG), parent_comm, msg_status, error)
|
|
! write(*,*) 'resetting ', message
|
|
! call reset(message)
|
|
counters(message) = 1
|
|
call MPI_Send(message, 1, MPI_INTEGER_MRCC, msg_status(MPI_SOURCE), msg_status(MPI_TAG), parent_comm, error)
|
|
|
|
case (REQ_ALLOCATECOUNTER)
|
|
#ifdef DEBUG
|
|
write(*,*) 'DEBUG: Manager allocating counter'
|
|
#endif
|
|
! call MPI_Recv(message, 1, MPI_INTEGER_MRCC, msg_status(MPI_SOURCE), msg_status(MPI_TAG), parent_comm, msg_status, error)
|
|
call MPI_Recv(message, 1, MPI_INTEGER_MRCC, msg_status(MPI_SOURCE), msg_status(MPI_TAG), parent_comm, msg_status, error)
|
|
call allocate_count(ncounter)
|
|
! write(*,*) 'sending ', ncounter, ' to ', msg_status(MPI_SOURCE)
|
|
call MPI_Send(ncounter, 1, MPI_INTEGER_MRCC, msg_status(MPI_SOURCE), REQ_ALLOCATECOUNTER, parent_comm, error)
|
|
|
|
case (REQ_DEALLOCATECOUNTER)
|
|
#ifdef DEBUG
|
|
write(*,*) 'DEBUG: Manager deallocating counter'
|
|
#endif
|
|
call MPI_Recv(ncounter, 1, MPI_INTEGER_MRCC, msg_status(MPI_SOURCE), msg_status(MPI_TAG), parent_comm, msg_status, error)
|
|
call deallocate_count(ncounter)
|
|
|
|
case (REQ_SENDFILE)
|
|
#ifdef DEBUG
|
|
write(*,*) 'DEBUG: Manager receiving file'
|
|
#endif
|
|
call receive_file
|
|
|
|
case default
|
|
write(*,'(a)') 'ERROR: Unknown request to manager.'
|
|
|
|
end select
|
|
|
|
end do
|
|
|
|
call usleep_f(1000)
|
|
end do outer
|
|
|
|
! close(1)
|
|
|
|
call MPI_Comm_disconnect(parent_comm, error)
|
|
! call sleep(5)
|
|
call MPI_Finalize(error)
|
|
|
|
call removePidFromList
|
|
|
|
contains
|
|
subroutine reset(ncounter)
|
|
implicit none
|
|
|
|
integer :: ncounter
|
|
|
|
#ifdef DEBUG
|
|
write(*,*) 'DEBUG: Manager resetting counter ', ncounter
|
|
#endif
|
|
|
|
counters(ncounter) = 1
|
|
! call MPI_Send(ncounter, 1, MPI_INTEGER_MRCC,
|
|
|
|
#ifdef DEBUG
|
|
write(*,*) 'DEBUG: Manager reset counter ', ncounter
|
|
#endif
|
|
|
|
end subroutine
|
|
|
|
subroutine send_increment_counter(counter, increment, destination, communicator)
|
|
implicit none
|
|
|
|
integer :: destination, communicator
|
|
integer :: counter, increment
|
|
|
|
#ifdef DEBUG
|
|
write(*,*) 'DEBUG: Manager sending counter ', counter, ' to ', destination
|
|
#endif
|
|
|
|
call MPI_Send(counter, 1, MPI_INTEGER_MRCC, destination, REQ_SENDCOUNTER, communicator, error)
|
|
counter = counter + increment
|
|
|
|
#ifdef DEBUG
|
|
write(*,*) 'DEBUG: Manager sent counter ', counter, ' to ', destination, ', new value ', counter
|
|
#endif
|
|
|
|
end subroutine
|
|
|
|
subroutine allocate_count(ncounter)
|
|
implicit none
|
|
|
|
integer :: ncounter
|
|
|
|
#ifdef DEBUG
|
|
write(*,*) 'DEBUG: Manager allocating counter'
|
|
#endif
|
|
|
|
do i = 1, MAX_COUNTERS
|
|
if(.not.counter_allocated(i)) then
|
|
counter_allocated(i) = .true.
|
|
exit
|
|
end if
|
|
end do
|
|
|
|
if(i == MAX_COUNTERS + 1) then
|
|
write(*, '(a)') 'ERROR: no free counter found'
|
|
call exit(1)
|
|
end if
|
|
|
|
counters(i) = 1
|
|
ncounter = i
|
|
|
|
#ifdef DEBUG
|
|
write(*,*) 'DEBUG: Manager allocated counter ', i
|
|
#endif
|
|
|
|
end subroutine
|
|
|
|
subroutine deallocate_count(ncounter)
|
|
implicit none
|
|
|
|
integer :: ncounter
|
|
|
|
#ifdef DEBUG
|
|
write(*,*) 'DEBUG: Manager deallocating counter ', ncounter
|
|
#endif
|
|
|
|
counter_allocated(ncounter) = .false.
|
|
|
|
#ifdef DEBUG
|
|
write(*,*) 'DEBUG: Manager deallocated counter ', ncounter
|
|
#endif
|
|
|
|
end subroutine
|
|
|
|
subroutine receive_file
|
|
implicit none
|
|
|
|
integer, parameter :: sunit = 100
|
|
integer :: length, iout
|
|
character(len = buffer_length) :: buffer
|
|
|
|
call MPI_Recv(length, 1, MPI_INTEGER_MRCC, msg_status(MPI_SOURCE), msg_status(MPI_TAG), parent_comm, msg_status, error)
|
|
if(length /= 0) then
|
|
call MPI_Recv(buffer, buffer_length, MPI_CHARACTER, msg_status(MPI_SOURCE), msg_status(MPI_TAG), parent_comm, msg_status, error)
|
|
open(unit = sunit, access = "stream", position = "append", file = trim(buffer(1:length)))
|
|
iout = sunit
|
|
else
|
|
iout = 6
|
|
end if
|
|
|
|
do
|
|
call MPI_Recv(length, 1, MPI_INTEGER_MRCC, msg_status(MPI_SOURCE), msg_status(MPI_TAG), parent_comm, msg_status, error)
|
|
if(length == -1) exit
|
|
call MPI_Recv(buffer, buffer_length, MPI_CHARACTER, msg_status(MPI_SOURCE), msg_status(MPI_TAG), parent_comm, msg_status, error)
|
|
if(iout /= 6) then
|
|
write(iout) buffer(1:length)
|
|
else
|
|
write(iout, '(a)', advance = "no") buffer(1:length)
|
|
end if
|
|
end do
|
|
|
|
if(iout /= 6) close(sunit)
|
|
|
|
end subroutine
|
|
|
|
end program
|
|
|
|
#endif
|