diff --git a/CMakeLists.txt b/CMakeLists.txt index 4a02aeb4..fe829356 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -100,7 +100,6 @@ endif() find_program(BASH_PROGRAM bash) -find_package(MPI REQUIRED COMPONENTS C Fortran) # Compiler-specific base flags and build profiles if(${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") # Base flags for all builds @@ -200,9 +199,6 @@ elseif(${CMAKE_Fortran_COMPILER_ID} STREQUAL "NVHPC") endif() endif() -include_directories(${MPI_Fortran_INCLUDE_PATH}) -message(STATUS "The MPI_Fortran_INCLUDE_PATH is ${MPI_Fortran_INCLUDE_PATH}") - # Detect and configure external dependencies (HDF5, NetCDF, FFTW) # Uses smoke tests to verify ABI compatibility with current compiler. # Falls back to building from source if system libraries are incompatible. @@ -210,7 +206,6 @@ include(${PROJECT_SOURCE_DIR}/cmake/DetectDependencies.cmake) # Libraries that libneo depends on add_subdirectory(src/contrib) -add_subdirectory(extra/MyMPILib) add_subdirectory(src/hdf5_tools) add_subdirectory(src/polylag) add_subdirectory(src/interpolate) diff --git a/README.md b/README.md index b0e2134e..41735775 100644 --- a/README.md +++ b/README.md @@ -142,10 +142,6 @@ Interface to hdf5, to simplify calls. ### contrib -### MyMPILib -Interface to MPI, so no actual mpi routines need to be called in -programs. - ### poincare Poincare plot generation for magnetic field lines. Computes field line trajectories and their intersections with toroidal cross-sections to visualize magnetic islands, diff --git a/doc/Doxyfile b/doc/Doxyfile index 1d73f770..f96ade7e 100644 --- a/doc/Doxyfile +++ b/doc/Doxyfile @@ -791,7 +791,6 @@ WARN_LOGFILE = # Note: If this tag is empty the current directory is searched. INPUT = ../src/ -INPUT += ../src/MyMPILib/Generic ../src/MyMPILib/Internal ../src/MyMPILib/Specific INPUT += ../src/hdf5_tools/ # This tag can be used to specify the character encoding of the source files diff --git a/doc/UserDoc/MyMPILib.tex b/doc/UserDoc/MyMPILib.tex deleted file mode 100644 index 4899660b..00000000 --- a/doc/UserDoc/MyMPILib.tex +++ /dev/null @@ -1,73 +0,0 @@ -\chapter{MyMPILib} -Basic interface to an mpi implementation, so the code requires no -mpi specific commands. -Utilizes a scheduler-worker model: -\begin{itemize} - \item scheduler - manager, distributes work and collects results - \item worker - does actual calculations -\end{itemize} - -\section{How to use} -Need to write scheduler module and wuGenericWorkunit module for your -code. -Former usally only needs to overwrite the specific part. - -\section{Code} -Code distributed into three folders - Generic, Internal and Specific. -Makes use of includes. - -these will include other files: -scheduler\_header.f90 -scheduler\_generic.f90 -scheduler\_module.f90 - -where the scheduler\_module will include the other two, and scheduler\_specific -Modules included are listener, comListener, wuListener, dispatcher, -comDispatcher and wuDispatcher. - -wu - work unit? - -\section{Todo} -\begin{itemize} - \item Add checkpointing? Could be based on unit of work, maybe needs - to be implemented in specific code instead. -\end{itemize} - - -Types: -type :: scheduler - -type, abstract :: packable - type, extends(packable) :: matrix - type, extends(packable), abstract :: workunit - type, extends(workunit) :: genericWorkunit - type, extends(genericWorkunit) :: wuMergeWorkunit - type, extends(wuMergeWorkunit) :: wuMergeChunk - type, extends(genericWorkunit) :: wuDataRequester - type, extends(genericworkunit) :: initWorkunit - -type :: dispatcher !< Sending signals? - type, extends(dispatcher) :: wuDispatcher - type, extends(dispatcher) :: comDispatcher - -type :: listener !< Receiving signals? - type, extends(listener) :: wuListener - type, extends(listener) :: comListener - -type :: globalSchedulerStorage -type :: packBuffer -type :: commandline_parser -type :: configFileParser -type :: mpelog -type :: myLogClass -type :: clientStatus - -type :: node - type, extends(node) :: packableNode - type, extends(node) :: workunitNode - type, extends(node) :: intnode - -type :: list - type, extends(list) :: packableList - type, extends(list) :: workunitList - type, extends(list) :: intlist diff --git a/extra/MyMPILib/.gitignore b/extra/MyMPILib/.gitignore deleted file mode 100644 index bd006aee..00000000 --- a/extra/MyMPILib/.gitignore +++ /dev/null @@ -1,12 +0,0 @@ -*.[oa] -*.mod -CMakeFiles/ -CMakeCache.txt -*.cmake -Makefile -BuildConfig.txt -CMakeLists.txt~ -.cproject -.metadata/ -.project - diff --git a/extra/MyMPILib/0_README b/extra/MyMPILib/0_README deleted file mode 100644 index 4a8354ca..00000000 --- a/extra/MyMPILib/0_README +++ /dev/null @@ -1,25 +0,0 @@ -1. Copy the file - ProjectConfig.cmake.sample - to - ProjectConfig.cmake.in - and edit the file for custom settings. - -2. Have a look at the file - CMakeLists.txt - to understand how the project is built. - -3. Enter the directory - Build-Release - and run - cmake .. - (The two dots are required to do an out-of-source build) - -4. Run - make && make install - to build an install the project. - -The out-of-source build method gives to ability to create new build directories for different compilers and configurations, without affecting other build configurations. -The compiler can be change in step 3 by running -cmake -DCMAKE_Fortran_COMPILER=ifort .. -instead of -cmake .. diff --git a/extra/MyMPILib/CMakeLists.txt b/extra/MyMPILib/CMakeLists.txt deleted file mode 100644 index e0d63339..00000000 --- a/extra/MyMPILib/CMakeLists.txt +++ /dev/null @@ -1,87 +0,0 @@ -cmake_minimum_required(VERSION 3.22) - -project (MyMPILib) -enable_language (C Fortran) - -# MPI -find_package (MPI REQUIRED COMPONENTS Fortran) - -include(${PROJECT_SOURCE_DIR}/ProjectConfig.cmake.in) -option(MPE_SUPPORT "Should the library be built with MPE-Support?" OFF) - -message(STATUS "The Compiler ID is ${CMAKE_Fortran_COMPILER_ID}") - -if(${CMAKE_Fortran_COMPILER_ID} STREQUAL "GNU") - - #gfortran -I/usr/lib/openmpi/include -pthread -I/usr/lib/openmpi/lib -L/usr//lib -L/usr/lib/openmpi/lib -lmpi_f90 -lmpi_f77 -lmpi -ldl -lhwloc - -# include_directories(${INCLUDEDIRS_MPI_GNU}) -# link_directories(${LINKDIRS_MPI_GNU}) - - set (CMAKE_Fortran_FLAGS "-cpp -pthread") - #set (CMAKE_Fortran_FLAGS_RELEASE "-O2") - #set (CMAKE_Fortran_FLAGS_DEBUG "") - -elseif (${CMAKE_Fortran_COMPILER_ID} STREQUAL "Intel") - - #ifort -I/usr/local/openmpi-1.6.3-intel/include -I/usr/local/openmpi-1.6.3-intel/lib -L/usr/local/openmpi-1.6.3-intel/lib -lmpi_f90 -lmpi_f77 -lmpi -ldl -lm -lnuma -Wl,--export-dynamic -lrt -lnsl -lutil - -# include_directories(${INCLUDEDIRS_MPI_INTEL}) -# link_directories(${LINKDIRS_MPI_INTEL}) - - set (CMAKE_Fortran_FLAGS "-cpp") - #set (CMAKE_Fortran_FLAGS_RELEASE "") - #set (CMAKE_Fortran_FLAGS_DEBUG "") -endif () - -set(CMAKE_Fortran_MODULE_DIRECTORY ${CMAKE_BINARY_DIR}) - -include_directories(${MPI_Fortran_INCLUDE_PATH}) -include_directories("${PROJECT_BINARY_DIR}") -include_directories("${PROJECT_SOURCE_DIR}/Generic") -include_directories("${PROJECT_SOURCE_DIR}/Specific") -include_directories("${PROJECT_SOURCE_DIR}/Internal") -include_directories("${PROJECT_SOURCE_DIR}/Tools") - -if (MPE_SUPPORT) - message(STATUS "MPE-Support activated, MPE-Path: ${MPE_PATH}") - if (DEFINED MPE_PATH) - include_directories(${MPE_PATH}/include) - endif () - add_definitions(-DMPE_SUPPORT) -endif () - -add_library(MyMPILib -${PROJECT_SOURCE_DIR}/Specific/packBuffer_module.f90 -${PROJECT_SOURCE_DIR}/Specific/mpiprovider_module.f90 -${PROJECT_SOURCE_DIR}/Tools/list_module.f90 -${PROJECT_SOURCE_DIR}/Internal/packable_module.f90 -${PROJECT_SOURCE_DIR}/Internal/matrix_module.f90 -${PROJECT_SOURCE_DIR}/Internal/clientStatus_module.f90 -${PROJECT_SOURCE_DIR}/Generic/workunit_module.f90 -${PROJECT_SOURCE_DIR}/Internal/wuDataRequester_module.f90 -${PROJECT_SOURCE_DIR}/Tools/intList_module.f90 -${PROJECT_SOURCE_DIR}/Tools/wuList_module.f90 -${PROJECT_SOURCE_DIR}/Tools/packableList_module.f90 -${PROJECT_SOURCE_DIR}/Tools/commandline_parser_module.f90 -${PROJECT_SOURCE_DIR}/Generic/scheduler_module.f90 -${PROJECT_SOURCE_DIR}/Tools/mpelog_module.f90 -${PROJECT_SOURCE_DIR}/Tools/myLog_module.f90 -${PROJECT_SOURCE_DIR}/Tools/configFile_parser_module.f90 -${PROJECT_SOURCE_DIR}/Internal/wuMergeWorkunit_module.f90 -${PROJECT_SOURCE_DIR}/Internal/wuMergeChunk_module.f90 -${PROJECT_SOURCE_DIR}/Generic/initWorkunit_module.f90 -${PROJECT_SOURCE_DIR}/Generic/genericWorkunit_module.f90 -) -target_link_libraries(MyMPILib PRIVATE MPI::MPI_Fortran) -install(TARGETS MyMPILib ARCHIVE DESTINATION lib) - -add_custom_target( - Versioning - COMMAND ${PROJECT_SOURCE_DIR}/Scripts/do_versioning.sh - WORKING_DIRECTORY ${PROJECT_SOURCE_DIR} -) - -add_dependencies(MyMPILib Versioning) - -add_library(LIBNEO::MyMPILib ALIAS MyMPILib) diff --git a/extra/MyMPILib/Examples/Allocate/0_README b/extra/MyMPILib/Examples/Allocate/0_README deleted file mode 100644 index d1af73d6..00000000 --- a/extra/MyMPILib/Examples/Allocate/0_README +++ /dev/null @@ -1,19 +0,0 @@ -1. Edit the file -CMakeLists.txt -in order to set the right library paths. - -2. Run -cmake . -in the directory of the example code. - -3. Run -./make.openmpi -to build the project. - -4. Edit the files -schedConfig.txt -intConfig.txt -to configure the Scheduler and the parameters of the integration. - -5. Run the executable file on 3 processes (2 clients, 1 scheduler) by the command -mpiexec -np 3 ./SimpleIntegration diff --git a/extra/MyMPILib/Examples/Allocate/CMakeLists.txt b/extra/MyMPILib/Examples/Allocate/CMakeLists.txt deleted file mode 100644 index 83a327ef..00000000 --- a/extra/MyMPILib/Examples/Allocate/CMakeLists.txt +++ /dev/null @@ -1,24 +0,0 @@ -cmake_minimum_required(VERSION 3.22) -project (AllocateTest) - -set(CMAKE_Fortran_COMPILER mpif90) -enable_language(Fortran) - -set(PROJLIBS /proj/plasma/Libs/) -### Directories of MyMPILib and MPE -set (MYMPILIB_PATH ${PROJLIBS}/MyMPILib/Build-Release) -set (MPE_PATH /afs/itp.tugraz.at/opt/mpe/1.3.0/) - -include_directories("${MYMPILIB_PATH}/OBJS") -set(MPI_lib -lmpi_f90 -lmpi_f77 -lmpi -lopen-rte -lopen-pal -ldl -Wl,--export-dynamic -lnsl -lutil -lm -ldl -pthread) -find_library(MyMPILib_lib MyMPILib ${MYMPILIB_PATH}) - -add_executable(allocatetest -main.f90 -) - -target_link_libraries(allocatetest - ${MyMPILib_lib} - ${MPI_lib} - /afs/itp.tugraz.at/opt/mpe/1.3.0/lib/libmpe.a -) diff --git a/extra/MyMPILib/Examples/Allocate/main.f90 b/extra/MyMPILib/Examples/Allocate/main.f90 deleted file mode 100644 index 935655c9..00000000 --- a/extra/MyMPILib/Examples/Allocate/main.f90 +++ /dev/null @@ -1,29 +0,0 @@ -program allocatetest - use mpiprovider_module - implicit none - - integer :: MPI_COMM_WORKERS - integer :: myrank, ierr - double precision, dimension(:), allocatable :: testmat - integer :: multiplier - - ! Initialize MPI (mpro is the singleton name of the MPIProvider) - !call mpro%init() - - myrank = mpro%getRank() - if (myrank .eq. 2) then - write (*,*) myrank - multiplier = 1d6 - else - multiplier = 1d4 - end if - allocate(testmat(1000*multiplier*(1))) - testmat = 1.1d0 - call sleep(120) - !write (*,*) testmat(1) - !deallocate(testmat) - - ! Close all connections by the use of the MPIProvider - !call mpro%deinit(.false.) - -end program allocatetest diff --git a/extra/MyMPILib/Examples/Allocate/schedConfig.txt b/extra/MyMPILib/Examples/Allocate/schedConfig.txt deleted file mode 100644 index 35da1a69..00000000 --- a/extra/MyMPILib/Examples/Allocate/schedConfig.txt +++ /dev/null @@ -1,7 +0,0 @@ -&nmlGenericScheduler -activateMPE = true -loadBalancing = true -buffersize=32 -verbose = 0 -/ - diff --git a/extra/MyMPILib/Examples/Gather/0_README b/extra/MyMPILib/Examples/Gather/0_README deleted file mode 100644 index d1af73d6..00000000 --- a/extra/MyMPILib/Examples/Gather/0_README +++ /dev/null @@ -1,19 +0,0 @@ -1. Edit the file -CMakeLists.txt -in order to set the right library paths. - -2. Run -cmake . -in the directory of the example code. - -3. Run -./make.openmpi -to build the project. - -4. Edit the files -schedConfig.txt -intConfig.txt -to configure the Scheduler and the parameters of the integration. - -5. Run the executable file on 3 processes (2 clients, 1 scheduler) by the command -mpiexec -np 3 ./SimpleIntegration diff --git a/extra/MyMPILib/Examples/Gather/CMakeLists.txt b/extra/MyMPILib/Examples/Gather/CMakeLists.txt deleted file mode 100644 index 46a69849..00000000 --- a/extra/MyMPILib/Examples/Gather/CMakeLists.txt +++ /dev/null @@ -1,27 +0,0 @@ -cmake_minimum_required(VERSION 3.22) -project (Gathertest) - -set(CMAKE_Fortran_COMPILER mpif90) -enable_language(Fortran) - -set(PROJLIBS /proj/plasma/Libs/) -### Directories of MyMPILib and MPE -set (MYMPILIB_PATH ${PROJLIBS}/MyMPILib/Build-Release) -set (MPE_PATH /afs/itp.tugraz.at/opt/mpe/1.3.0/) - -include_directories("${MYMPILIB_PATH}/OBJS") -set(MPI_lib -lmpi_f90 -lmpi_f77 -lmpi -lopen-rte -lopen-pal -ldl -Wl,--export-dynamic -lnsl -lutil -lm -ldl -pthread) -find_library(MyMPILib_lib MyMPILib ${MYMPILIB_PATH}) - -add_executable(gathertest -main.f90 -#wuIntegrate_module.f90 -#simpleIntScheduler_module.f90 -#integrate_module.f90 -) - -target_link_libraries(gathertest - ${MyMPILib_lib} - ${MPI_lib} - /afs/itp.tugraz.at/opt/mpe/1.3.0/lib/libmpe.a -) diff --git a/extra/MyMPILib/Examples/Gather/intconfig.txt b/extra/MyMPILib/Examples/Gather/intconfig.txt deleted file mode 100644 index 62c0ea77..00000000 --- a/extra/MyMPILib/Examples/Gather/intconfig.txt +++ /dev/null @@ -1,7 +0,0 @@ -&nmlIntegrate -a=-4 -b=+4 -n=200000000 -subintervals=100 -/ - diff --git a/extra/MyMPILib/Examples/Gather/main.f90 b/extra/MyMPILib/Examples/Gather/main.f90 deleted file mode 100644 index b000a90e..00000000 --- a/extra/MyMPILib/Examples/Gather/main.f90 +++ /dev/null @@ -1,47 +0,0 @@ -!> Demonstration program for numerical integration -program simpleintegrate - use mpiprovider_module - implicit none - - integer :: MPI_COMM_WORKERS - double complex, dimension(1:5, 1:4, 0:3) :: A - double precision, dimension(1:5) :: B - integer :: myrank, ierr - - ! Initialize MPI (mpro is the singleton name of the MPIProvider) - call mpro%init() - - !if (mpro%getNumProcs() .eq. 1) then - - myrank = mpro%getRank() - B = 0d0 - B(myrank) = myrank*10 - !A = 0 - !A(:,:,myrank) = 10*(myrank+1) - !A(:,:,myrank) = 10*myrank - - !call MPI_ALLGATHER(A(1:5, myrank), 5, MPI_DOUBLE_COMPLEX, A, 5, MPI_DOUBLE_COMPLEX, MPI_COMM_WORLD, ierr) - !call mpro%allgather(A(:,:,myrank), A) - call mpro%allgather(B(myrank), B) - write (*,*) myrank, B - stop - !write (*,*) myrank, A(2,2,:) - - ! Try a spawn - !call MPI_Comm_spawn('./gathertest', MPI_ARGV_NULL, 3, & - !MPI_INFO_NULL, 0, MPI_COMM_WORLD, MPI_COMM_WORKERS, & - !MPI_ERRCODES_IGNORE, ierr) - - !call mpro%barrier() - !else - - !write (*,*) "This seems to be a spwaned worker" - !write (*,*) "I am ", mpro%getRank(), mpro%getNumProcs() - - !call mpro%barrier() - !end if - - ! Close all connections by the use of the MPIProvider - call mpro%deinit(.false.) - -end program simpleintegrate diff --git a/extra/MyMPILib/Examples/Gather/make.openmpi b/extra/MyMPILib/Examples/Gather/make.openmpi deleted file mode 100755 index a815c7e8..00000000 --- a/extra/MyMPILib/Examples/Gather/make.openmpi +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/bash -OMPI_FC=/usr/local/bin/gfortran-4.7.0 make diff --git a/extra/MyMPILib/Examples/Gather/schedConfig.txt b/extra/MyMPILib/Examples/Gather/schedConfig.txt deleted file mode 100644 index 35da1a69..00000000 --- a/extra/MyMPILib/Examples/Gather/schedConfig.txt +++ /dev/null @@ -1,7 +0,0 @@ -&nmlGenericScheduler -activateMPE = true -loadBalancing = true -buffersize=32 -verbose = 0 -/ - diff --git a/extra/MyMPILib/Generic/genericWorkunit_module.f90 b/extra/MyMPILib/Generic/genericWorkunit_module.f90 deleted file mode 100644 index 98c98817..00000000 --- a/extra/MyMPILib/Generic/genericWorkunit_module.f90 +++ /dev/null @@ -1,116 +0,0 @@ -!> Module for class generic workunit -module genericWorkunit_module - - use workunit_module - use mpiprovider_module - - !> Class generic Workunit - type, extends(workunit) :: genericWorkunit - contains - - procedure :: init => init_genericWorkunit !< Constructor - procedure :: pack => pack_genericWorkunit !< Generic pack - procedure :: unpack => unpack_genericWorkunit !< Generic unpack - procedure :: deinit => deinit_genericWorkunit !< Destructor - procedure :: free => free_genericworkunit !< Generic free - procedure :: print => print_genericWorkunit !< Empty print - - procedure :: process => process_genericWorkunit !< Represents the job of the workunit - - procedure :: setClient => setClient_genericworkunit - procedure :: setOldClient => setOldClient_genericworkunit - procedure :: setDrUID => setDrUID_genericworkunit - - end type genericWorkunit - -contains - - !> This subroutine has to be inherited to give the workunit the opportunity to print itself - subroutine print_genericWorkunit(this) - class(genericWorkunit) :: this - - end subroutine print_genericWorkunit - - !> This subroutine has to be inherted to define the job of the workunit - subroutine process_genericWorkunit(this) - class(genericWorkunit) :: this - - end subroutine process_genericWorkunit - - !> Constructor, call this%genericWorkunit%init() in the constructor of the inherted workunit - subroutine init_genericWorkunit(this) - class(genericWorkunit) :: this - - this%uid = mpro%storage%nextUID - mpro%storage%nextUId = mpro%storage%nextUID + 1 - - call this%neededWUs%init() - end subroutine init_genericWorkunit - - !> Generic pack of internal variables of the workunit. - !> This has to be called in the inherited workunit before packing other variables - subroutine pack_genericworkunit(this) - class(genericworkunit) :: this - - call mpro%packBuffer%add_string(this%type) - - call mpro%packBuffer%add_int(this%uid) - call mpro%packBuffer%add_int(this%client) - call mpro%packBuffer%add_bool(this%sendBack) - call mpro%packBuffer%add_bool(this%isProcessed) - - end subroutine pack_genericworkunit - - !> Generic unpack of internal variables, has to be called before unpacking other data - subroutine unpack_genericworkunit(this) - class(genericworkunit) :: this - - call mpro%packBuffer%resetPos() - call mpro%packBuffer%get_string(this%type) - call mpro%packBuffer%get_int(this%uid) - - call mpro%packBuffer%get_int(this%client) - - call mpro%packBuffer%get_bool(this%sendBack) - call mpro%packBuffer%get_bool(this%isProcessed) - end subroutine unpack_genericworkunit - - !> Frees the neededWUs-list - subroutine free_genericworkunit(this) - class(genericworkunit) :: this - - call this%neededWUs%free() - end subroutine free_genericworkunit - - !> Destructor - subroutine deinit_genericworkunit(this) - class(genericworkunit) :: this - - call this%neededWUs%free() - end subroutine deinit_genericworkunit - - !> Setter for datarequester-id - subroutine setDrUID_genericworkunit(this, druid) - class(genericworkunit) :: this - integer :: druid - - this%druid = druid - end subroutine setDrUID_genericworkunit - - !> Setter for oldClient, used for dataRequester - subroutine setOldClient_genericworkunit(this, cl) - class(genericworkunit) :: this - integer :: cl - - this%oldClient = cl - end subroutine setOldClient_genericworkunit - - !> Setter of client id - subroutine setClient_genericworkunit(this, cl) - class(genericworkunit) :: this - integer :: cl - - this%client= cl - end subroutine setClient_genericworkunit - -end module genericWorkunit_module diff --git a/extra/MyMPILib/Generic/initWorkunit_module.f90 b/extra/MyMPILib/Generic/initWorkunit_module.f90 deleted file mode 100644 index 313d06c7..00000000 --- a/extra/MyMPILib/Generic/initWorkunit_module.f90 +++ /dev/null @@ -1,68 +0,0 @@ -!> Module for class initWorkunit -module initWorkunit_module - - use mpiprovider_module - use genericworkunit_module - - implicit none - - !> Used to inherit a specific initial workunit - type, extends(genericworkunit) :: initWorkunit - - contains - procedure :: init => init_InitWorkunit - procedure :: process => process_InitWorkunit - procedure :: free => free_InitWorkunit - procedure :: print => print_InitWorkunit - procedure :: pack => pack_InitWorkunit - procedure :: unpack => unpack_InitWorkunit - procedure :: get => get_InitWorkunit - end type initWorkunit - -contains - - !> Constructor - subroutine init_InitWorkunit(this) - class(initWorkunit) :: this - - end subroutine init_InitWorkunit - - !> This subroutine has to be overwritten for defining special init-processes - subroutine process_initWorkunit(this) - class(initWorkunit) :: this - - end subroutine process_initWorkunit - - !> Can be used for getting data from the init-workunit - function get_InitWorkunit(this, uid) result(res) - class(initWorkunit) :: this - integer, intent(in) :: uid - class(packable), pointer :: res - - end function get_InitWorkunit - - !> Destructor - subroutine free_initWorkunit(this) - class(initWorkunit) :: this - - end subroutine free_initWorkunit - - subroutine pack_initWorkunit(this) - class(initWorkunit) :: this - - write (*,*) "InitWU: Pack here not needed" - end subroutine pack_initWorkunit - - subroutine unpack_initWorkunit(this) - class(initWorkunit) :: this - - write (*,*) "InitWU: Unpack here not needed" - end subroutine unpack_initWorkunit - - subroutine print_initWorkunit(this) - class(initWorkunit) :: this - - write(*,*) "InitWU: Print not yet implemented" - end subroutine print_initWorkunit - -end module initWorkunit_module diff --git a/extra/MyMPILib/Generic/scheduler_generic.f90 b/extra/MyMPILib/Generic/scheduler_generic.f90 deleted file mode 100644 index 2b30aab8..00000000 --- a/extra/MyMPILib/Generic/scheduler_generic.f90 +++ /dev/null @@ -1,838 +0,0 @@ -! Body file of generic scheduler - - include "listener_body.f90" - include "comListener_body.f90" - include "wuListener_body.f90" - - include "dispatcher_body.f90" - include "comDispatcher_body.f90" - include "wuDispatcher_body.f90" - -!> Constructor of generic scheduler -subroutine init_scheduler(this) - class(scheduler) :: this - integer :: stat - integer :: f = 500 - character(len=100) :: msg - - mpro%schedInitTime = MPI_WTime() - - ! Namelist reading removed due to nvfortran 25.11 bug - using defaults - write (*,*) "MyMPILib: Using default scheduler settings (namelist disabled for nvfortran compatibility)" - ! Set values of nameList - this%balance = loadBalancing - myLog%verbose = verbose - mlog%active = activateMPE - - call mpro%allocateBuffers(buffersize) - - this%isRunning = .false. - - ! Allocate Array for Clients - allocate(this%clientStats(1:mpro%getNumProcs()-1)) - - ! Allocate workunit lists - allocate(mpro%storage%waitingWorkunits) - allocate(mpro%storage%pendingWorkunits) - allocate(mpro%storage%processedWorkunits) - - mpro%storage%processedWorkunits%sortList = .false. - - ! Initialize Listeners and Dispatchers - call this%tComDisp%init() - call this%tComListener%init(this) - call this%tWuDisp%init() - call this%tWuListener%init(this) - - if (mpro%getRank() .eq. 0 ) then - !Initialize the logging on the master process - call mylog%init() - end if - - call mlog%init(mpro%getRank()) - -end subroutine init_scheduler - -!> Wrapper for adding workunits to waitingWorkunits list -subroutine addWorkunit_scheduler(this, wu) - class(scheduler) :: this - class(workunit) :: wu - - call mpro%storage%waitingWorkunits%add(wu) - -end subroutine addWorkunit_scheduler - -!> Destructor of generic scheduler -subroutine deinit_scheduler(this) - class(scheduler) :: this - - if (allocated(this%workunits_per_client)) deallocate(this%workunits_per_client) - - if (mpro%getRank() .eq. 0) then - - ! Performance output - call this%printPerformanceAnalysis() - - ! Send TERM-Signal to all clients - call this%tComDisp%sendTermSignal() - - ! Stop the logging - call mylog%deinit() - end if - - ! Stop MPE logger - call mlog%deinit() - - ! Do cleaning up activities - call this%cleanup() - - mpro%schedDeinitTime = MPI_WTime() - -end subroutine deinit_scheduler - -!> Prints a performance analysis section -subroutine printPerformanceAnalysis_scheduler(this) - class(scheduler) :: this - integer :: i - write (*,*) "Scheduler: All jobs are done!" - - write (*,*) "----- PERFORMANCE ANALYSIS (Scheduler) -----" - write (*,*) "Client MeanTime" - do i = 1, mpro%getNumProcs()-1 - write (*,'(I7, F12.3)') i, this%clientStats(i)%meanWorkTime - call this%clientStats(i)%free() - end do - write (*,*) "" - - write (*,*) "----- PERFORMANCE ANALYSIS (Client) -----" - write (*,*) " Workunits Time[s] Total[s] DataRequesters Time[s] Packtime[s]" - - ! Wait for flushing output - call sleep(1) - - ! Print all processed work units - ! call mpro%processedWorkunits%print() - -end subroutine printPerformanceAnalysis_scheduler - -!> Routine for the partition of a number of work units depending on the number of clients -subroutine partNearlyFair_scheduler(this, workunits_count) - class(scheduler) :: this - integer :: workunits_count - - integer :: client_count - integer :: workunits_per_client - integer :: workunits_offset - integer :: workunits_offset_left - integer :: current_client - integer :: workunits_left_client - - client_count = mpro%getNumProcs() - 1 - allocate(this%workunits_per_client(1:client_count)) - - workunits_per_client = workunits_count / client_count - workunits_offset = mod(workunits_count, client_count) - - do current_client = 1, client_count - workunits_left_client = workunits_per_client - if (workunits_offset > 0) then - workunits_left_client = workunits_left_client + 1 - workunits_offset = workunits_offset - 1 - end if - - this%workunits_per_client(current_client) = workunits_left_client - end do -end subroutine partNearlyFair_scheduler - -!> Internal routine for controlling the merge-process of merge-able objects, e.g., matrices -subroutine repairNeighbors_scheduler(this, p_uid, ln, wu_uid, rn) - class(scheduler) :: this - integer :: p_uid, ln, wu_uid, rn - - class(workunit), pointer :: selectWU => null() - - selectWU => mpro%storage%processedWorkunits%get(p_uid) - select type (last => selectWU) - class is (wuMergeWorkunit) - - call last%setMerged(.true.) - end select - - - ! Repair right Neighbors - if (ln /= -1) then - selectWU => mpro%storage%processedWorkunits%get(ln, .false.) - if (associated(selectWU)) then - select type (q1 => selectWU) - class is (wuMergeWorkunit) - call q1%setNeighbors(q1%leftNeighbor, wu_uid) - end select - else - selectWU => mpro%storage%pendingWorkunits%get(ln, .false.) - if (associated(selectWU)) then - select type (q2 => selectWU) - class is (wuMergeWorkunit) - call q2%setNeighbors(q2%leftNeighbor, wu_uid) - end select - else - selectWU => mpro%storage%waitingWorkunits%get(ln) - if (associated(selectWU)) then - select type (q3 => selectWU) - class is (wuMergeWorkunit) - call q3%setNeighbors(q3%leftNeighbor, wu_uid) - end select - end if - end if - end if - end if - - ! Repair left Neighbors - if (rn /= -1) then - selectWU => mpro%storage%processedWorkunits%get(rn, .false.) - if (associated(selectWU)) then - select type (q1 => selectWU) - class is (wuMergeWorkunit) - call q1%setNeighbors(wu_uid, q1%rightNeighbor) - end select - else - selectWU => mpro%storage%pendingWorkunits%get(rn, .false.) - if (associated(selectWU)) then - select type (q2 => selectWU) - class is (wuMergeWorkunit) - call q2%setNeighbors(wu_uid, q2%rightNeighbor) - end select - else - selectWU => mpro%storage%waitingWorkunits%get(rn) - if (associated(selectWU)) then - select type (q3 => selectWU) - class is (wuMergeWorkunit) - call q3%setNeighbors(wu_uid, q3%rightNeighbor) - end select - end if - end if - end if - end if -end subroutine repairNeighbors_scheduler - -!> Function to allocate a work unit -function allocateWU_scheduler(this, wuType) result(res) - class(scheduler) :: this - character(len=maxStrLen) :: wuType - class(workunit), pointer :: res - - nullify(res) - select case (wutype) - case ("wuDataRequester") - allocate(wuDataRequester :: res) - case default - ! If no matching work unit has been found, then the specific routine of the inherited scheduler is called - ! Therefore, the generic scheduler has to be inherited if new work units are introduced. - res => this%allocateSpecific(wuType) - end select - - if (.not. associated(res)) then - write (*,*) "Recieved unknown workunit!! (type = ", wuType, "). Maybe you have forgotten to pack something?" - stop - end if - -end function allocateWU_scheduler - -!> Allocates merge-able work units -function allocateMergeWU_scheduler(this) result(res) - class(scheduler) :: this - character(len=maxStrLen) :: wuType - class(wuMergeWorkunit), pointer :: res - - nullify(res) - res => this%allocateSpecificMergeWu() - - if (.not. associated(res)) then - write (*,*) "Received unknown work unit! Maybe you have forgotten to pack something?" - stop - end if - -end function allocateMergeWU_scheduler - -!> Routine to rebuild a received workunit and to process it -subroutine rebuildWU_scheduler(this) - class(scheduler) :: this - class(workunit), pointer :: wu - integer :: uid - character(len=maxStrLen) :: wutype - double precision :: stime, etime - - ! Check which Workunit - call mpro%packBuffer%resetPos() - call mpro%packBuffer%get_string(wutype) - !write (*,*) mpro%getRank(), "The type is: ", type - - if (mpro%getRank() > 0) then - - ! Allocate object - wu => this%allocateWU(wuType) - - ! Initialize and Unpack the received workunit - call wu%init() - - call wu%unpack() - ! Add workunit to list - call mpro%storage%waitingWorkunits%add(wu) - !call mpro%waitingWorkunits%print() - - stime = MPI_WTime() - ! Decide if processing is needed - if (.not. wu%isProcessed) then - - !write (*,*) mpro%getRank(), "Processing ", wu%uid - call mlog%logEvent(mpe_e_compA) - call wu%process() - call mlog%logEvent(mpe_e_compB) - - else - !write (*,*) mpro%getRank(), "Workunit ", wu%uid, "already processed, nothing to do!" - !write (*,*) mpro%getRank(), "Received a processed workunit", wu%uid - end if - - this%lastWuID = wu%uid - - ! Performance recordings - etime = MPI_WTime() - this%proTime = this%proTime + (etime - stime) - - mpro%wuTime = mpro%wuTime + (etime - stime) - mpro%wuCount = mpro%wuCount + 1 - - else - - ! Receive a sendBack work unit - call mpro%packBuffer%get_int(uid) - wu => mpro%storage%processedWorkunits%get(uid) - call wu%unpack() - - !write (*,*) "Scheduler recieved sendBack-workunit" - end if - -end subroutine rebuildWU_scheduler - -!> Runs the init workunit on the client -subroutine runInitWU_scheduler(this) - class(scheduler) :: this - double precision :: stime, etime - - ! Run the init-workunit on every client, when the INIT-command was received - write (*,"(A, I2, A, A, A)") "This is ", mpro%getRank(), " on ", trim(mpro%getProcName()), " running the Init-WU!" - - if (associated(mpro%initWU)) then - call mpro%initWU%init() - - stime = MPI_WTime() - call mpro%initWU%process() - etime = MPI_WTime() - - select type (q => mpro%initWU) - class is (initWorkunit) - - class default - write (*,*) "FATAL Error: No matching INIT-WU found!" - end select - else - write (*,*) mpro%getRank(), "No Init-WU defined!, Skipping..." - end if - -end subroutine runInitWU_scheduler - -!> Import routine which is called, when scheduler receives a Ready-signal from a client. -!> Re-links objects of the work unit - lists, sets clients states and more -subroutine setClientStatus_scheduler(this, source, status) - class(scheduler) :: this - integer :: source - logical, optional :: status - integer :: wuid - class(workunit), pointer :: wu - - - if (.not. present(status)) then - - ! Check, if client has pendingWorkunits - if (this%clientStats(source)%lastWUs%getCount() > 0) then - - call this%clientStats(source)%lastWUs%rewind() - wuid = this%clientStats(source)%lastWUs%getCurrent() - - wu => mpro%storage%pendingWorkunits%get(wuid) - - select type (q => wu) - class is (wuDataRequester) - if (this%clientStats(q%dest)%isBlocked) then - this%clientStats(q%dest)%isBlocked = .false. - !write (*,*) "Unblocking client", q%dest - else - write (*,*) "FATAL Warning: Requesting to unblock Client ", q%dest, " while it is not blocked!" - write (*,*) "Additional information: DR (", q%uid, ")" - stop - end if - !this%clientStats(q%dest)%isReady = .true. - end select - - ! Relink last pending workunit (FIFO) - call mpro%storage%pendingWorkunits%relinkElementTo(mpro%storage%processedWorkunits, wu) - call mylog%logRelinkPendToProc(wuid) - - ! Reduce spool count - this%clientStats(source)%wuSpool = this%clientStats(source)%wuSpool - 1 - call this%clientStats(source)%lastWUs%del(wuid) - call this%clientStats(source)%myWorkunits%add(wuid) - this%clientStats(source)%workunitsLeft = this%clientStats(source)%workunitsLeft - 1 - - this%clientStats(source)%isReady = .true. - if (this%clientStats(source)%lastWUs%getCount() > 0) then - this%clientStats(source)%isReady = .false. - end if - !write (*,*) "Setting status of", source, "to", this%clientStats(source)%isReady, wuid - - else - if (mpro%getRank() == 0) then - write (*,*) "FATAL ERROR: Client response not expected" - write (*,*) "Information: Client ", source - stop - else - !write (*,*) mpro%getRank(), "gets a response from", source - end if - end if - else - write (*,*) "WARNING: no stat" - this%clientStats(source)%isReady = status - end if - -end subroutine setClientStatus_scheduler - -!> Callback function for listener, when receiving a stop-signal -subroutine terminate_scheduler(this) - class(scheduler) :: this - - this%isRunning = .false. -end subroutine terminate_scheduler - -!> Initiates the init-workunit on the clients and waits for them to finish -subroutine initPhase_scheduler(this) - class(scheduler) :: this - integer, dimension(MPI_STATUS_SIZE) :: status - integer :: ierr, tag, i, source - character(len=4) :: buffer - - if (associated(mpro%initWU)) then - write (*,*) "Init-Phase" - ! Send INIT-Signal to all clients to start the Init-Workunit - call this%tComDisp%sendInitSignal() - - call mpro%initWU%init() - - ! Init-Phase - Wait for REDY-Signal from every client - do i=1, mpro%getNumProcs()-1 - call MPI_PROBE(MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD, status, ierr) - tag = status(MPI_TAG) - source = status(MPI_SOURCE) - !write (*,*) mpro%getRank(), "Received a message with tag = ", tag, "from ", status(MPI_SOURCE) - - call mpro%recv(source, tag, buffer) - if (buffer == "REDY") this%clientStats(source)%isReady = .true. - end do - - do i = 1, mpro%getNumProcs()-1 - if (.not. this%clientStats(source)%isReady) then - write (*,*) "Not all clients responded, aborting." - stop - end if - end do - - else - write (*,*) "No Init-Workunit defined, skipping prepare()" - end if - -end subroutine initPhase_scheduler - -!> Does some cleaning-ups after running the scheduling process and prints benchmark information. -subroutine cleanup_scheduler(this) - class(scheduler) :: this - integer :: i - - ! Deallocate array for clients - deallocate(this%clientStats) - - mpro%storage%nextUID = 1 - this%lastWuId = -1 - - call mpro%storage%waitingWorkunits%free() - call mpro%storage%pendingWorkunits%free() - call mpro%storage%processedWorkunits%free() - - deallocate(mpro%storage%waitingWorkunits) - deallocate(mpro%storage%pendingWorkunits) - deallocate(mpro%storage%processedWorkunits) - -end subroutine cleanup_scheduler - -!> Needed for scheduler Version 1 -function getPendingNodesCount_scheduler(this) result(res) - class(scheduler) :: this - integer :: res - integer :: i - - res = 0 - do i = 1, mpro%getNumProcs()-1 - res = res + this%clientStats(i)%pendingNodes%getCount() - end do - -end function getPendingNodesCount_scheduler - -!> The core routine of the scheduler. Iterates over all waiting workunits and dispatches them to the clients -subroutine processWaitingWorkunits_scheduler(this) - class(scheduler) :: this - integer :: ierr, source, tag, i, uid, wuCount, req, cl, nextAutoClient - real :: wuPercent, wuPercentBefore - logical :: depCheck, probeFlag - integer, dimension(MPI_STATUS_SIZE) :: status - - double precision :: time, stime, etime, timeDiff, sCalctime, eCalctime, sLoop, eLoop, tLoop, sLoop1, eLoop1, tLoop1 - character(8) :: date - character(10) :: strtime - character(len=8+4) :: res - - class(workunit), pointer :: currentWU => null() - - call date_and_time(date, strtime) - - write (*,*) "Scheduler: All workunits are prepared! Count = ", mpro%storage%waitingWorkunits%getCount() - write (*,*) "Starting framework at ", date, " ", strtime(1:4) - - sCalctime = MPI_WTime() - - time = 0 - nextAutoClient = 1 - - ! Set client neighbors for merging of Scheduler Version 1 - do i = 1, mpro%getNumProcs()-1 - this%clientStats(i)%nextNeighbor = i + 1 - end do - this%clientStats(mpro%getNumProcs()-1)%nextNeighbor = 0 - - wuCount = mpro%storage%waitingWorkunits%getCount() - wuPercent = 0 - tloop = 0 - tloop1 = 0 - - req = MPI_REQUEST_NULL - - ! --- Distribute workunits to clients --- - ! Loop until every workunit has been send to a client - do while (((mpro%storage%waitingWorkunits%getCount() > 0) .or. (mpro%storage%pendingWorkunits%getCount() > 0)) & - .or. (this%getPendingNodesCount() > 1)) - - ! Rewind list-iterator to first element - call mpro%storage%waitingWorkunits%rewind() - - call mlog%logEvent(mpe_e_busyA) - - ! Iterate through list until the last element is reached - tloop = 0 - do while (associated(mpro%storage%waitingWorkunits%currentElement)) - - currentWU => mpro%storage%waitingWorkunits%getCurrent() - - if (currentWU%client == -1) then ! Client auto detection - call currentWU%setClient(nextAutoClient) - !write (*,*) "AutoClient: ", nextAutoClient, q%uid - nextAutoClient = nextAutoClient + 1 - if (nextAutoClient >= mpro%getNumProcs()) nextAutoClient = 1 - end if - - !if (this%clientStats(q%client)%wuSpool < 1) then - ! write (*,*) "Warning, Spool of ", q%client, " gets empty!", this%clientStats(q%client)%wuSpool - !end if - - ! If the particular client is ready then prepare to sen - if (this%clientStats(currentWU%client)%isReady .and. & - (.not. this%clientStats(currentWU%client)%isBlocked)) then! .or. this%clientStats(q%client)%wuSpool < this%maxSpool) then - - ! Check dependencies - sloop = MPI_WTime() - depCheck = .true. - call currentWU%neededWUs%rewind() - do while (associated(currentWU%neededWUs%currentElement)) - uid = currentWU%neededWUs%getCurrent() - if (.not. mpro%storage%processedWorkunits%hasElement(uid) .and. & - (.not. this%clientStats(currentWU%client)%lastWUs%hasElement(uid))) then - depCheck = .false. - end if - - call currentWU%neededWUs%gotoNext() - end do - - eloop = MPI_WTime() - tloop = tloop + (eloop - sloop) - - if (depCheck) then - - sloop1 = MPI_WTime() - - ! Pack and Send - call MPI_WAIT(req, status, ierr) - call mpro%packBuffer%clear() - - call currentWU%pack() - - call myLog%logSending(0, currentWU%client, currentWU%uid) - - req = this%tWuDisp%isend(currentWU%client) - - if (this%clientStats(currentWU%client)%lastTime > 0) then - timeDiff = MPI_WTime() - this%clientStats(currentWU%client)%lastTime - this%clientStats(currentWU%client)%meanWorkTime = & - 0.5*(this%clientStats(currentWU%client)%meanWorkTime + timeDiff) - end if - - this%clientStats(currentWU%client)%lastTime = MPI_WTime() - this%clientStats(currentWU%client)%isReady = .false. - this%clientStats(currentWU%client)%isDone = .false. - - call this%clientStats(currentWU%client)%lastWUs%add(currentWU%uid) - - this%clientStats(currentWU%client)%wuSpool = this%clientStats(currentWU%client)%wuSpool + 1 - - !write (*,*) "Scheduler sending WU", q%uid, " to ", q%client - - ! Relink element to pending-workunits - list - call myLog%logRelinkWaitToPend(currentWU%uid) - call mpro%storage%waitingWorkunits%relinkElementTo(mpro%storage%pendingWorkunits, currentWU) - cl = currentWU%client - call mpro%storage%waitingWorkunits%rewind() - - eloop1 = MPI_WTime() - tloop1 = tloop1 + (eloop1 - sloop1) - - else - !write (*,*) "Dependencies of workunit ", q%uid, " for client ", q%client," not yet fullfilled!" - !call q%neededWUs%print() - - ! Iterate to next workunit - call mpro%storage%waitingWorkunits%gotoNext() - end if !DepCheck - - else - call mpro%storage%waitingWorkunits%gotoNext() - end if !Client ready? - - end do - - call MPI_WAIT(req, status, ierr) - call mlog%logEvent(mpe_e_busyB) - - ! --- --- - - ! Percentage output - wuPercentBefore = wuPercent; - wuPercent = 100.0 - (real(mpro%storage%waitingWorkunits%getCount() + & - mpro%storage%pendingWorkunits%getCount()) / wuCount)*100; - if ((int(wuPercent / 10) /= int(wuPercentBefore / 10)) .and. (wuPercentBefore <= 99)) then - if (wuPercent > wuPercentBefore) then - write(*,"(A, A, A, F6.2, A, A, A)") achar(27), '[32m', ' ----- ', wuPercent, "% done -----", achar(27), '[0m' - end if - end if - - stime = MPI_WTime() - - ! ------ Listening -------- - if (mpro%storage%pendingWorkunits%getCount() > 0) then - !--- Listening --- - - ! write (*,*) "Probing...", mpro%storage%pendingWorkunits%getCount(), mpro%storage%waitingWorkunits%getCount() - !call mpro%storage%pendingWorkunits%print() - call MPI_PROBE(MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD, status, ierr) - !write (*,*) "Probing Done" - - probeFlag = .true. - do while (probeFlag) - - call MPI_IPROBE(MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD, probeFlag, status, ierr) - if (probeFlag) then - tag = status(MPI_TAG) - source = status(MPI_SOURCE) - call this%tComListener%doListen(source, tag) - call this%tWuListener%doListen(source, tag) - end if - - end do - - ! Check, if one client is completely finished and can send his result to the next neighbor - call this%checkIfClientDone() - call this%loadBalancing() - - !--- End Listening --- - else - write (*,*) "The scheduler detected a possible deadlock! Aborting program!" - call mpro%storage%waitingWorkunits%print() - call mpro%storage%processedWorkunits%print() - stop - end if - - etime = MPI_WTime() - time = time + (etime - stime) - - end do - - eCalctime = MPI_WTime() - write (*,"(A, F12.2, A)") " Scheduler needed ", (eCalctime - sCalctime), " s for processing all work units." - write (*,"(A, F12.2, A)") " Scheduler spent ", time, " s for waiting for responses." - write (*,"(A, I6)") " Balanced work units: ", mpro%balanceCount - - !call this%tcomDisp%sendPrintSignal(1) - - !write (*,*) "Scheduling done, printing processed work units:" - !call mpro%storage%processedWorkunits%print() - -end subroutine processWaitingWorkunits_scheduler - -!> Used for printing the last processed workunit on a client -subroutine printLast_scheduler(this) - class(scheduler) :: this - class(workunit), pointer :: wu - - write (*,*) "Printing last element:" - wu => mpro%storage%waitingWorkunits%get(this%lastWuId) - call wu%print() - -end subroutine printLast_scheduler - -!> This functions runs on a client, when starting the scheduling -subroutine initClient_scheduler(this) - class(scheduler) :: this - integer :: ierr - integer, dimension(MPI_STATUS_SIZE) :: stat - integer :: tag, source - double precision :: stime, etime, time - integer :: countsOfRedy - class(workunit), pointer :: wu - logical :: sendBack - integer :: i - double precision :: wuTimeOverWuCount, drTimeOverDrCount, drPacktimeOverDrCount - - time = 0 - - this%isRunning = .true. - countsOfRedy = 1 - - ! Run until TERM-Signal - do while (this%isRunning) - stime = MPI_WTime() - ! Check for new messages - - call MPI_PROBE(MPI_ANY_SOURCE, MPI_ANY_TAG, MPI_COMM_WORLD, stat, ierr) - tag = stat(MPI_TAG) - source = stat(MPI_SOURCE) - - etime = MPI_WTime() - time = time + (etime - stime) - !write (*,*) mpro%getRank(), "Received a message with tag = ", tag, " from ", source - - ! Call listeners - call this%tComListener%doListen(source, tag) - call this%tWuListener%doListen(source, tag) - - sendBack = .false. - if (tag == wuTag) then - wu => mpro%storage%waitingWorkunits%get(this%lastWUid) - sendBack = wu%sendBack - end if - - ! Send REDY to scheduler - if (source == 0) then - if (this%isRunning) then - !write (*,*) mpro%getRank(), " sends ready because of ", this%lastWUid - if (.not. sendBack) then - call this%tComDisp%sendSignal("REDY", source) - else - !write (*,*) "Client ", mpro%getRank(), " sending Workunit to scheduler" - - call wu%pack() - call this%tWuDisp%send(0) - end if - end if - end if - end do - - ! Deinitialize everything - !call mpro%initWU%free() - call mpro%storage%waitingWorkunits%free() - call this%tComListener%deinit() - - ! Synchronize timing information output - do i = 1, mpro%getNumProcs() - - call MPI_BARRIER(mpro%mpi_comm_clients, ierr) - if (i == mpro%getRank()) then - - wuTimeOverWuCount = 0 - drTimeOverDrCount = 0 - drPacktimeOverDrCount = 0 - - if (mpro%wuCount .ne. 0) wuTimeOverWuCount = mpro%wuTime / mpro%wuCount - if (mpro%drCount .ne. 0) then - drTimeOverDrCount = mpro%drTime / mpro%drCount - drPackTimeOverDrCount = mpro%drPackTime / mpro%drCount - end if - - write (*,"(A, I6, A4, A10, I13, F10.3, F11.3, I18, F10.3, F15.3)") & - " Details for node", mpro%getRank(), " on ", mpro%getProcName(), & - mpro%wuCount, wuTimeOverWuCount, mpro%wuTime, & - mpro%drCount,drTimeOverDrCount, drPacktimeOverDrCount - - end if - end do - -end subroutine initClient_scheduler - -!> Initias the initPhase on the clients -subroutine prepare_scheduler(this) - class(scheduler) :: this - - call this%loadSettings() - - if (mpro%getNumProcs() > 1) then - ! Decide if master or client - if (mpro%getRank() .eq. 0) then - ! Call initWorkunit on every client - call this%initPhase() - end if - end if - -end subroutine prepare_scheduler - -!> Starts the scheduling process on master and client -subroutine schedule_scheduler(this) - class(scheduler) :: this - - if (mpro%getNumProcs() > 1) then - - ! Decide if master or client - if (mpro%getRank() .eq. 0) then - - ! Prepare all workunits -> This will be specific for the problem - call this%initMaster() - - ! Process all workunits - call this%processWaitingWorkunits() - - ! Call summarize-routine (can be overwritten by the user) - call this%summarize() - - else - ! Set client to ready-mode for recvieving workunits - call this%initClient() - end if - else - ! No parallel execution, - ! Run in linear mode - call this%initLinear() - end if - -end subroutine schedule_scheduler diff --git a/extra/MyMPILib/Generic/scheduler_header.f90 b/extra/MyMPILib/Generic/scheduler_header.f90 deleted file mode 100644 index dee7c3ce..00000000 --- a/extra/MyMPILib/Generic/scheduler_header.f90 +++ /dev/null @@ -1,82 +0,0 @@ - - include "listener_header.f90" - include "comListener_header.f90" - include "wuListener_header.f90" - - include "dispatcher_header.f90" - include "comDispatcher_header.f90" - include "wuDispatcher_header.f90" - - !> Settings for the generic scheduler (hardcoded defaults - namelist removed for nvfortran bug) - logical :: loadBalancing = .false. - integer :: bufferSize = 32 !Megabytes - integer :: verbose = 0 - logical :: activateMPE = .false. - - !> Basic scheduler class with matmul performance testing - type :: scheduler - type(comListener) :: tComListener !< Listener for commands - type(comDispatcher) :: tComDisp !< Dispatcher for commands - type(wuListener) :: tWuListener !< Listener for workunits - type(wuDispatcher) :: tWuDisp !< Dispatcher for workunits - - character(len=maxStrLen) :: configFilename = "./schedConfig.txt"!< Sets the filename for the namelist - - logical :: isRunning !< .true. when scheduling is running - type(clientStatus), dimension(:), allocatable :: clientStats !< This array stores informations for every client - - double precision :: proTime = 0 !< For performance analysis, marks the time spent in workunits - - integer :: lastWuId = -1 !< Stores the last workunit processed by the client, used for printing the result - integer :: maxSpool = 1 !< Scheduler 1 is implemented with spool support to send workunits to clients, even when they are not ready - logical :: balance = .false. !< Scheduler 2 and 3 are implemented with loadBalancing support - - integer, allocatable, dimension(:) :: workunits_per_client - - - ! Main lists for workunit processing - type(workunitlist), allocatable :: waitingWorkunits !< Workunits which have not been sent to a client yet - type(workunitlist), allocatable :: pendingWorkunits !< Workunits which are already on clients - type(workunitlist), allocatable :: processedWorkunits !< Workunits which are completely done - - !> UID for next packable object - integer :: nextUID = 1 - - contains - procedure :: init => init_scheduler - procedure :: deinit => deinit_scheduler - procedure :: terminate => terminate_scheduler - - procedure :: addWorkunit => addWorkunit_scheduler - procedure :: getPendingNodesCount => getPendingNodesCount_scheduler - - procedure :: allocateWU => allocateWU_scheduler - procedure :: allocateMergeWU => allocateMergeWU_scheduler - - procedure :: initPhase => initPhase_scheduler - procedure :: runInitWU => runInitWU_scheduler - procedure :: prepare => prepare_scheduler - procedure :: summarize => summarize_scheduler - procedure :: schedule => schedule_scheduler - procedure :: processWaitingWorkunits => processWaitingWorkunits_scheduler - procedure :: rebuildWU => rebuildWU_scheduler - procedure :: setClientStatus => setClientStatus_scheduler - procedure :: cleanup => cleanup_scheduler - procedure :: partNearlyFair => partNearlyFair_scheduler - procedure :: repairNeighbors => repairNeighbors_scheduler - - procedure :: printLast => printLast_scheduler - procedure :: printPerformanceAnalysis => printPerformanceAnalysis_scheduler - - ! This subroutines CAN BE overwritten for special behaviour - procedure, private :: initMaster => initMaster_scheduler - procedure, private :: loadSettings => loadSettings_scheduler - procedure, private :: initClient => initClient_scheduler - procedure, private :: initLinear => initLinear_scheduler - procedure, private :: checkIfClientDone => checkIfClientDone_scheduler ! Corresponds to dynamicWorkunits() - procedure, private :: loadBalancing => loadBalancing_scheduler - - ! This subroutines HAVE TO be inherited when creating a new scheduler with new workunits - procedure :: allocateSpecific => allocateSpecific_scheduler - procedure :: allocateSpecificMergeWU => allocateSpecificMergeWU_scheduler - end type scheduler diff --git a/extra/MyMPILib/Generic/scheduler_module.f90 b/extra/MyMPILib/Generic/scheduler_module.f90 deleted file mode 100644 index 501b3006..00000000 --- a/extra/MyMPILib/Generic/scheduler_module.f90 +++ /dev/null @@ -1,27 +0,0 @@ -!> This is the main module of the scheduler class -!> Used to inhert a special scheduler which is specific for a special physical problem -module scheduler_module - - use list_module - use intlist_module - use mpiprovider_module - use matrix_module - use clientStatus_module - use workunit_module - use wuDataRequester_module - use initWorkunit_module - - implicit none - - ! Header definitions - include "scheduler_header.f90" - -contains - - ! Generic part, in most cases there is no need to adapt this part for special problems - include "scheduler_generic.f90" - - ! Specific part, these functions have to be overwritten to adapt the library to a special problem - include "scheduler_specific.f90" - -end module scheduler_module diff --git a/extra/MyMPILib/Generic/workunit_module.f90 b/extra/MyMPILib/Generic/workunit_module.f90 deleted file mode 100644 index 9cce8595..00000000 --- a/extra/MyMPILib/Generic/workunit_module.f90 +++ /dev/null @@ -1,73 +0,0 @@ -!> Module for abstract class workunit, for documentation see genericWorkunit -module workunit_module - - use packable_module - use intList_module - - implicit none - - type, extends(packable), abstract :: workunit - real :: fracIndex !< Required for special purposes (correct sort order for matrix multiplication) - character(len=1024) :: type = '' !< Defines the type of the workunit to allocate the correct class. Has to be unique! - integer :: client = -1 !< Defines the client on which the workunit will run - integer :: oldClient = -1 !< Defines the client which was suspected to run the workunit, but has maybe changed by loadbalancing - integer :: druid = -1 !< UID of datarequester - - - logical :: balance = .false. !< Indicates, if work unit can be balanced automatically - logical :: isProcessed = .false. !< Indicates if workunit has already been processed - logical :: sendBack = .false. !< If true, the result of the workunit will be send back to the scheduler - type(intList) :: neededWUs !< Dependencies - - contains - - procedure(iinit), deferred :: init - procedure(iprocess), deferred :: process - - procedure(isetClient), deferred :: setClient - procedure(isetOldClient), deferred :: setOldClient - procedure(isetDrUID), deferred :: setDrUID - - end type workunit - - abstract interface - - subroutine iinit(this) - import workunit - class(workunit) :: this - - end subroutine - - subroutine isetDrUID(this, druid) - import workunit - class(workunit) :: this - integer :: druid - - end subroutine isetDrUID - - subroutine isetOldClient(this, cl) - import workunit - - class(workunit) :: this - integer :: cl - - end subroutine isetOldClient - - subroutine isetClient(this, cl) - import workunit - - class(workunit) :: this - integer :: cl - - end subroutine isetClient - - subroutine iprocess(this) - import workunit - - class(workunit) :: this - - end subroutine iprocess - - end interface - -end module workunit_module diff --git a/extra/MyMPILib/Internal/clientStatus_module.f90 b/extra/MyMPILib/Internal/clientStatus_module.f90 deleted file mode 100644 index 37de8cc6..00000000 --- a/extra/MyMPILib/Internal/clientStatus_module.f90 +++ /dev/null @@ -1,70 +0,0 @@ -!> Module for class clientStatus -module clientStatus_module - use workunit_module - use intlist_module - use wulist_module - - implicit none - - !> Class clientStatus: - !> Stores information per client - type clientStatus - - !> Defines the rank of the process - integer :: rank = -1 - - !> True, if client has no Workunits pending - logical :: isReady = .true. - - !> For blocking client when it should recveive from a dataRequester - logical :: isBlocked = .false. - - logical :: isDone = .false. - - !> If working with spools, the number of workunits pending on the client - integer :: wuSpool = 0 - - !> For merge process of Sched1 - integer :: nextNeighbor - - !> For merge process of Sched1: Defines which nodes have to be locally merged - type(workunitList) :: pendingNodes - - !> For performance analysis - double precision :: lastTime = -1 - - !> Mean time, the client needed for a workunit - double precision :: meanWorkTime = 0 - - !> Units per client, used to calculate mergetrees - integer :: upc - - !> Defines the workunits, the client has in local memory - type(intList) :: myWorkunits - - !> Workunits, which have been sent to the client, but not processed, yet - type(intList) :: lastWUs - - integer :: workunitsLeft = -1 - - !> Required for Scheduler 2 and 3 to indicate that the client has local merge possibilities, before requesting workunits from other clients - logical :: localMerge = .false. - - contains - - !> Destructor - procedure :: free => free_clientStatus - end type clientStatus - -contains - - !> Destructor - subroutine free_clientStatus(this) - class(clientStatus) :: this - - call this%myWorkunits%free(); - call this%pendingNodes%free(.false.); - call this%lastWUs%free(); - end subroutine free_clientStatus - -end module clientStatus_module diff --git a/extra/MyMPILib/Internal/comDispatcher_body.f90 b/extra/MyMPILib/Internal/comDispatcher_body.f90 deleted file mode 100644 index 7c6c7166..00000000 --- a/extra/MyMPILib/Internal/comDispatcher_body.f90 +++ /dev/null @@ -1,87 +0,0 @@ -!> Constructor -subroutine init_comDispatcher(this) - class(comDispatcher) :: this - - ! Defines the tag for sending and listening - this%iTag = comTag -end subroutine init_comDispatcher - -!> Stops all clients from listening -subroutine sendTermSignal_comDispatcher(this, dest) - class(comDispatcher) :: this - integer, optional :: dest !< Destination rank - - if (mpro%getNumProcs() > 1) then - - ! Decision if broadcasting or not - if (present(dest)) then - call this%send(dest, "TERM") - else - call this%sendBroadcast("TERM") - end if - - end if -end subroutine sendTermSignal_comDispatcher - -!> Starts the InitWU on the clients -subroutine sendInitSignal_comDispatcher(this, dest) - class(comDispatcher) :: this - integer, optional :: dest !< Destination rank - - ! Decision if broadcasting or not - if (present(dest)) then - call this%send(dest, "INIT") - else - call this%sendBroadcast("INIT") - end if -end subroutine sendInitSignal_comDispatcher - -!> Sends the command to print the last processed workunit to one client -subroutine sendPrintSignal_comDispatcher(this, dest) - class(comDispatcher) :: this - integer, optional :: dest !< Destination rank - - ! Decision if broadcasting or not - if (present(dest)) then - call this%send(dest, "PRNT") - else - call this%sendBroadcast("PRNT") - end if -end subroutine sendPrintSignal_comDispatcher - -!> Generic function to send a command string to a client -subroutine sendSignal_comDispatcher(this, buf, dest) - class(comDispatcher) :: this - character(len=4) :: buf !< Command string (max. length 4) - integer, optional :: dest !< Destination rank, leave empty to send a broadcast - - ! Decision if broadcasting or not - if (present(dest)) then - call this%send(dest, buf) - else - call this%sendBroadcast(buf) - end if -end subroutine sendSignal_comDispatcher - -!> Wrapper function for sending the command -subroutine send_comDispatcher(this, dest, command) - class(comDispatcher) :: this - integer :: dest !< Destination rank - character(len=4) :: command !< Command string (max. length 4) - - ! Send command - call mpro%send(dest, this%iTag, command) - -end subroutine send_comDispatcher - -!> Wrapper function for sending a broadcast command -subroutine sendBroadcast_comDispatcher(this, command) - class(comDispatcher) :: this - character(len=4) :: command !< Command string - integer :: i - - ! Broadcasting - do i = 1, mpro%getNumProcs()-1 - call this%send(i, command) - end do -end subroutine sendBroadcast_comDispatcher diff --git a/extra/MyMPILib/Internal/comDispatcher_header.f90 b/extra/MyMPILib/Internal/comDispatcher_header.f90 deleted file mode 100644 index 41e4fe24..00000000 --- a/extra/MyMPILib/Internal/comDispatcher_header.f90 +++ /dev/null @@ -1,13 +0,0 @@ - !> Class definition for comDispatcher, see body file for documentation of the functions - type, extends(dispatcher) :: comDispatcher - - contains - procedure :: init => init_comDispatcher - procedure, private :: send => send_comDispatcher - procedure, private :: sendBroadcast => sendBroadcast_comDispatcher - - procedure :: sendTermSignal => sendTermSignal_comDispatcher - procedure :: sendInitSignal => sendInitSignal_comDispatcher - procedure :: sendPrintSignal=> sendPrintSignal_comDispatcher - procedure :: sendSignal => sendSignal_comDispatcher - end type comDispatcher diff --git a/extra/MyMPILib/Internal/comListener_body.f90 b/extra/MyMPILib/Internal/comListener_body.f90 deleted file mode 100644 index eb4ec11d..00000000 --- a/extra/MyMPILib/Internal/comListener_body.f90 +++ /dev/null @@ -1,44 +0,0 @@ -!> Constructor -subroutine init_comListener(this, mySched) - class(comListener) :: this - class(scheduler), target :: mySched !< Pointer to the parent scheduler - - !Define scheduler for callbacks - this%myScheduler => mySched - - this%iTag = comTag -end subroutine init_comListener - -!> Execute listening process, function checks if tag is allowed for this listener -subroutine doListen_comListener(this, source, tag) - class(comListener) :: this - integer :: tag !< Listening tag - integer :: source !< Source rank - character(len=4) :: buffer - - ! Only receive, if tags are corresponding - if (tag == this%iTag) then - - ! Wrapper for MPI receive command - call mpro%recv(source, tag, buffer) - - if (buffer == "TERM") then - call terminate_scheduler(this%myScheduler) - !call this%myScheduler%terminate() ! Works since gfortran-4.7.0 - end if - if (buffer == "INIT") then - call runInitWU_scheduler(this%myScheduler) - !call this%myScheduler%runInitWU() - end if - if (buffer == "REDY") then - call setClientStatus_scheduler(this%myScheduler, source) - !call this%myScheduler%setClientStatus(source) - end if - if (buffer == "PRNT") then - call printLast_scheduler(this%myScheduler) - !call this%myScheduler%printLast() - end if - - end if - -end subroutine doListen_comListener diff --git a/extra/MyMPILib/Internal/comListener_header.f90 b/extra/MyMPILib/Internal/comListener_header.f90 deleted file mode 100644 index 48d67337..00000000 --- a/extra/MyMPILib/Internal/comListener_header.f90 +++ /dev/null @@ -1,8 +0,0 @@ - !> Class definition for comListener - type, extends(listener) :: comListener - - contains - procedure :: init => init_comListener - procedure :: doListen => doListen_comListener - end type comListener - diff --git a/extra/MyMPILib/Internal/dispatcher_body.f90 b/extra/MyMPILib/Internal/dispatcher_body.f90 deleted file mode 100644 index 263e4269..00000000 --- a/extra/MyMPILib/Internal/dispatcher_body.f90 +++ /dev/null @@ -1,11 +0,0 @@ -!> Constructor of dispatcher -subroutine init_dispatcher(this) - class(dispatcher) :: this - -end subroutine init_dispatcher - -!> Destructor of dispatcher -subroutine deinit_dispatcher(this) - class(dispatcher) :: this - -end subroutine deinit_dispatcher diff --git a/extra/MyMPILib/Internal/dispatcher_header.f90 b/extra/MyMPILib/Internal/dispatcher_header.f90 deleted file mode 100644 index cf1080b4..00000000 --- a/extra/MyMPILib/Internal/dispatcher_header.f90 +++ /dev/null @@ -1,8 +0,0 @@ -!> Class dispatcher, see body for documentation - type :: dispatcher - integer :: iTag !< Defines the tag for sending - integer :: iErr !< Indicates errors - contains - procedure :: init => init_dispatcher - procedure :: deinit => deinit_dispatcher - end type dispatcher diff --git a/extra/MyMPILib/Internal/listener_body.f90 b/extra/MyMPILib/Internal/listener_body.f90 deleted file mode 100644 index 18757942..00000000 --- a/extra/MyMPILib/Internal/listener_body.f90 +++ /dev/null @@ -1,19 +0,0 @@ - !> Constructor of listener - subroutine init_listener(this, mySched) - class(listener) :: this - class(scheduler), target :: mySched - - end subroutine init_listener - - !> Listen routine, should be called after MPI_PROBE - subroutine doListen_listener(this, source, tag) - class(listener) :: this - integer :: source, tag - - end subroutine doListen_listener - - !> Destructor - subroutine deinit_listener(this) - class(listener) :: this - - end subroutine deinit_listener diff --git a/extra/MyMPILib/Internal/listener_header.f90 b/extra/MyMPILib/Internal/listener_header.f90 deleted file mode 100644 index 2726fbef..00000000 --- a/extra/MyMPILib/Internal/listener_header.f90 +++ /dev/null @@ -1,10 +0,0 @@ - !> Class listener - type :: listener - integer :: iTag !< Defines the tag for listening - class(scheduler), pointer :: myScheduler => null() !< Defines the scheduler for callback functions - contains - procedure :: init => init_listener - procedure :: deinit => deinit_listener - - procedure :: doListen => doListen_listener - end type listener diff --git a/extra/MyMPILib/Internal/matrix_module.f90 b/extra/MyMPILib/Internal/matrix_module.f90 deleted file mode 100644 index 0bf6a8cf..00000000 --- a/extra/MyMPILib/Internal/matrix_module.f90 +++ /dev/null @@ -1,70 +0,0 @@ -!> Matrix module, which can pack itself -module matrix_module - use packable_module - - implicit none - - !> Class matrix - type, extends(packable) :: matrix - real, dimension(:,:), allocatable :: mat !< data - contains - procedure :: print => print_matrix - procedure :: pack => pack_matrix - procedure :: unpack => unpack_matrix - procedure :: free => free_matrix - - procedure :: alloc => alloc_matrix - end type matrix - -contains - - !> Wrapper for allocation - subroutine alloc_matrix(this, a, b, c, d) - class(matrix) :: this - integer, intent(in) :: a, b, c, d - - allocate(this%mat(a:b, c:d)) - end subroutine alloc_matrix - - !> Free memory - subroutine free_matrix(this) - class(matrix) :: this - - if (allocated(this%mat)) deallocate(this%mat) - end subroutine free_matrix - - subroutine unpack_matrix(this) - class(matrix) :: this - write (*,*) "Matrix: Unpack not yet implemented" - - end subroutine unpack_matrix - - subroutine pack_matrix(this) - class(matrix) :: this - write (*,*) "Matrix: Pack not yet implemented!" - - end subroutine pack_matrix - - subroutine print_matrix(this) - class(matrix) :: this - integer :: ub1, ub2, lb1, lb2 - - lb1 = lbound(this%mat, 1) - ub1 = ubound(this%mat, 1) - - lb2 = lbound(this%mat, 2) - ub2 = ubound(this%mat, 2) - - write (*,*) this%uid, "Result dimensions: ", lb1, ub1, lb2, ub2 - - ! Nice printout - !do i = lb1, ub1 - ! do j = lb2, ub2 - ! write (*, '(E15.5)', advance='no') this%mat(i, j) - ! end do - ! write (*,*) - !end do - - end subroutine print_matrix - -end module matrix_module diff --git a/extra/MyMPILib/Internal/packable_module.f90 b/extra/MyMPILib/Internal/packable_module.f90 deleted file mode 100644 index b85bf4f0..00000000 --- a/extra/MyMPILib/Internal/packable_module.f90 +++ /dev/null @@ -1,38 +0,0 @@ -!> Module for abstract class packable -module packable_module - - !> Abstract class packable - !> If an object gets inherited from this class, it has the ability of packing and printing itself - type, abstract :: packable - integer :: uid = -1 - contains - procedure(iprint), deferred :: print - procedure(ipack), deferred :: pack - procedure(iunpack), deferred :: unpack - procedure(ifree), deferred :: free - end type packable - - abstract interface - - subroutine ifree(this) - import packable - class(packable) :: this - end subroutine ifree - - subroutine iprint(this) - import packable - class(packable) :: this - end subroutine iprint - - subroutine ipack(this) - import packable - class(packable) :: this - end subroutine ipack - - subroutine iunpack(this) - import packable - class(packable) :: this - end subroutine iunpack - end interface - -end module packable_module diff --git a/extra/MyMPILib/Internal/wuDataRequester_module.f90 b/extra/MyMPILib/Internal/wuDataRequester_module.f90 deleted file mode 100644 index c332abd2..00000000 --- a/extra/MyMPILib/Internal/wuDataRequester_module.f90 +++ /dev/null @@ -1,146 +0,0 @@ -!> Module for class datarequester -module wuDataRequester_module - use genericWorkunit_module - use mpiprovider_module - use list_module - - use initWorkunit_module - use wuMergeChunk_module - - - implicit none - - !> Class wuDataRequester, used for sending workunits between clients - type, extends(genericWorkunit) :: wuDataRequester - - integer :: whichUID !< Which workunit - integer :: dest !< Target client - - contains - procedure :: process => process_wuDataRequester - procedure :: print => print_wuDataRequester - procedure :: pack => pack_wuDataRequester - procedure :: unpack => unpack_wuDataRequester - procedure :: free => free_wuDataRequester - procedure :: init => init_wuDataRequester - end type wuDataRequester - -contains - - !> Constructor sets the type and the next UID - subroutine init_wuDataRequester(this) - class(wuDataRequester) :: this - - this%type = "wuDataRequester" - - ! Call the scheduler of parent class - call this%genericworkunit%init() - - end subroutine init_wuDataRequester - - subroutine print_wuDataRequester(this) - class(wuDataRequester) :: this - - write (*,*) "DataRequester ", this%client, this%uid, this%whichUID, this%dest - end subroutine print_wuDataRequester - - !> This routine packs and sends a workunit from one client to another - subroutine process_wuDataRequester(this) - class(wuDataRequester) :: this - class(packable), pointer :: wu - !integer, dimension(MPI_STATUS_SIZE) :: stat - character(len=4) :: buffer - double precision :: stime, etime, spacktime, epacktime - - stime = MPI_WTime() - !write (*,*) "Requesting ", this%whichUID, this%dest - - wu => mpro%storage%waitingWorkunits%get(this%whichUID) - !if (wu%type == 3) then - select type (q => wu) - class is (wuMergeChunk) - this%whichUID = q%resultUID - - !call mpro%storage%waitingWorkunits%print() - if (mpro%storage%waitingWorkunits%hasElement(this%whichUID)) then - wu => mpro%storage%waitingWorkunits%get(this%whichUID) - else - write (*,*) "Error in dataRequester, element not found", this%whichUID - stop - end if - end select - !end if - call mpro%packBuffer%clear() - spacktime = MPI_WTime() - call wu%pack() - epacktime = MPI_WTime() - !write (*,*) "DataRequester on", this%client, this%uid ,"sending", wu%uid, "to", this%dest - - call mpro%packBuffer%ssendTo(this%dest, wuTag) - - ! Another possibility: - - !!$ req = mpro%packBuffer%isendTo(this%dest, 111) - !!$ - !!$ flag = .false. - !!$ errormsg = .false. - !!$ emergCounter = 0 - !!$ st = MPI_WTIME() - !!$ do while (.not. flag) - !!$ call MPI_TEST(req, flag, stat, ierr) - !!$ emergCounter = emergCounter + 1 - !!$ !write (*,*) "waiting..." - !!$ if (MPI_WTIME() - st > 10) then - !!$ write (*,*) mpro%getRank(), "maybe in a deadlock" - !!$ ! emergCounter = 0 - !!$ end if - !!$ end do - !!$ !write (*,*) "DONE.", mpro%getRank(), this%uid - !!$ - !!$ call mlog%logEvent(mpe_e_recvA) - !call MPI_WAIT(req, stat, ierr) - !!$ - !!$ !write (*,*) "DataReq is waiting for", this%dest - !! call mpro%recv(this%dest, 77, buffer) - !!$ !write (*,*) "OK" - !!$ call mlog%logEvent(mpe_e_recvB, this%dest, 77) - this%isProcessed = .true. - - etime = MPI_WTime() - mpro%drcount = mpro%drcount + 1 - mpro%drTime = mpro%drTime + (etime - stime) - mpro%drPackTime = mpro%drPackTime + (epacktime - spacktime) - end subroutine process_wuDataRequester - - !> Unpack envelope of datarequester - subroutine unpack_wuDataRequester(this) - class(wuDataRequester) :: this - - call this%genericWorkunit%unpack() - - call mpro%packBuffer%get_int(this%whichUID) - call mpro%packBuffer%get_int(this%dest) - end subroutine unpack_wuDataRequester - - !> Pack envelope of datarequester - subroutine pack_wuDataRequester(this) - class(wuDataRequester) :: this - - call this%genericWorkunit%pack() - - call mpro%packBuffer%add_int(this%whichUID) - call mpro%packBuffer%add_int(this%dest) - - if (this%isProcessed) then - - end if - end subroutine pack_wuDataRequester - - !> Free memory - subroutine free_wuDataRequester(this) - class(wuDataRequester) :: this - - call this%genericWorkunit%free() - end subroutine free_wuDataRequester - -end module wuDataRequester_module diff --git a/extra/MyMPILib/Internal/wuDispatcher_body.f90 b/extra/MyMPILib/Internal/wuDispatcher_body.f90 deleted file mode 100644 index 69d88d09..00000000 --- a/extra/MyMPILib/Internal/wuDispatcher_body.f90 +++ /dev/null @@ -1,24 +0,0 @@ -!> Constructor of wuDispatcher sets the tag for sending workunits -subroutine init_wuDispatcher(this) - class(wuDispatcher) :: this - this%iTag = wuTag -end subroutine init_wuDispatcher - -!> Calls the send routine from mpiprovider -subroutine send_wuDispatcher(this, destRank) - class(wuDispatcher) :: this - integer :: destRank - - !write (*,*) "Sending buffer to ", destRank - call mpro%packBuffer%sendTo(destRank, this%iTag) - -end subroutine send_wuDispatcher - -!> Calls the isend routine from mpiprovider -function isend_wuDispatcher(this, destRank) result(res) - class(wuDispatcher) :: this - integer :: destRank - integer :: res - - res = mpro%packBuffer%iSendTo(destRank, this%iTag) -end function isend_wuDispatcher diff --git a/extra/MyMPILib/Internal/wuDispatcher_header.f90 b/extra/MyMPILib/Internal/wuDispatcher_header.f90 deleted file mode 100644 index 75b06dad..00000000 --- a/extra/MyMPILib/Internal/wuDispatcher_header.f90 +++ /dev/null @@ -1,9 +0,0 @@ -!> Child class of dispatcher -type, extends(dispatcher) :: wuDispatcher - - contains - procedure :: init => init_wuDispatcher - procedure :: send => send_wuDispatcher - procedure :: isend => isend_wuDispatcher - -end type wuDispatcher diff --git a/extra/MyMPILib/Internal/wuListener_body.f90 b/extra/MyMPILib/Internal/wuListener_body.f90 deleted file mode 100644 index 10d50d96..00000000 --- a/extra/MyMPILib/Internal/wuListener_body.f90 +++ /dev/null @@ -1,31 +0,0 @@ -!> Constructor sets the tag for listining for workunits -subroutine init_wuListener(this, mySched) - class(wuListener) :: this - class(scheduler), target :: mySched - - this%myScheduler => mySched - this%iTag = wuTag -end subroutine init_wuListener - -!> Listens for workunits and calls the rebuildWU-routine fo scheduler -subroutine doListen_wuListener(this, source, tag) - class(wuListener) :: this - integer :: tag, source - - if (tag == this%iTag) then - - call mpro%packBuffer%receiveFrom(source, this%iTag) - if (mpro%getRank() > 0) then - call rebuildWU_scheduler(this%myScheduler) - !call this%myScheduler%rebuildWU()!rebuildWU_scheduler(this%myScheduler) - else - - call setClientStatus_scheduler(this%myScheduler, source) - call rebuildWU_scheduler(this%myScheduler) - - !call this%myScheduler%setClientStatus(source) - !call this%myScheduler%rebuildWU()!rebuildWU_scheduler(this%myScheduler) - end if - end if - -end subroutine doListen_wuListener diff --git a/extra/MyMPILib/Internal/wuListener_header.f90 b/extra/MyMPILib/Internal/wuListener_header.f90 deleted file mode 100644 index be71c413..00000000 --- a/extra/MyMPILib/Internal/wuListener_header.f90 +++ /dev/null @@ -1,7 +0,0 @@ - !> Child class of listener - type, extends(listener) :: wuListener - - contains - procedure :: init => init_wuListener - procedure :: doListen => doListen_wuListener - end type wuListener diff --git a/extra/MyMPILib/Internal/wuMergeChunk_module.f90 b/extra/MyMPILib/Internal/wuMergeChunk_module.f90 deleted file mode 100644 index e3230cda..00000000 --- a/extra/MyMPILib/Internal/wuMergeChunk_module.f90 +++ /dev/null @@ -1,16 +0,0 @@ -!> Module for class wuMergeChunk -module wuMergeChunk_module - - use wuMergeWorkunit_module - - implicit none - - !> Child class of wuMergeWorkunit, for collection of workunits - type, extends(wuMergeWorkunit) :: wuMergeChunk - integer :: startUID - integer :: rangeUID - integer :: uidOffset - contains - - end type wuMergeChunk -end module wuMergeChunk_module diff --git a/extra/MyMPILib/Internal/wuMergeWorkunit_module.f90 b/extra/MyMPILib/Internal/wuMergeWorkunit_module.f90 deleted file mode 100644 index 6fe36628..00000000 --- a/extra/MyMPILib/Internal/wuMergeWorkunit_module.f90 +++ /dev/null @@ -1,97 +0,0 @@ -!> Module for class wuMergeWorkunit -module wuMergeWorkunit_module - - use genericworkunit_module - use mpiprovider_module - - implicit none - - !> This workunit is special for mergeWorkunits, which means that two workunits get merged to one - !> For example matrix multiplication - type, extends(genericWorkunit) :: wuMergeWorkunit - integer :: idxM1, idxM2 = -1 - integer :: sourceM1, sourceM2 = 1 !0... initWU, 1... processedList - - integer :: leftNeighbor = -1 - integer :: rightNeighbor = -1 - - integer :: resultUID = -1 - - logical :: isMerged = .false. - logical :: doNotMerge = .false. - - contains - procedure :: process => process_wuMergeWorkunit - procedure :: print => print_wuMergeWorkunit - procedure :: pack => pack_wuMergeWorkunit - procedure :: unpack => unpack_wuMergeWorkunit - procedure :: free => free_wuMergeWorkunit - procedure :: init => init_wuMergeWorkunit - - procedure :: setNeighbors => setNeighbors_wuMergeWorkunit - procedure :: setMerged => setMerged_wuMergeWorkunit - procedure :: setMergeInfo => setMergeInfo_wuMergeWorkunit - end type wuMergeWorkunit - -contains - - subroutine init_wuMergeWorkunit(this) - class(wuMergeWorkunit) :: this - this%uid = mpro%storage%nextUID - this%resultuid = this%uid - mpro%storage%nextUId = mpro%storage%nextUID + 1 - !this%type = 1 - call this%neededWUs%init() - - end subroutine init_wuMergeWorkunit - - subroutine setMergeInfo_wuMergeWorkunit(this, left_uid, right_uid) - class(wuMergeWorkunit) :: this - integer :: left_uid, right_uid - - end subroutine setMergeInfo_wuMergeWorkunit - - subroutine setMerged_wuMergeWorkunit(this, m) - class(wuMergeWorkunit) :: this - logical, intent(in) :: m - - this%isMerged = m - end subroutine setMerged_wuMergeWorkunit - - subroutine setNeighbors_wuMergeWorkunit(this, ln, rn) - class(wuMergeWorkunit) :: this - integer, intent(in) :: ln, rn - !write (*,*) "This is MergeWorkunit", this%uid, "and someone sets my neighbors to", ln, rn - this%leftNeighbor = ln - this%rightNeighbor = rn - end subroutine setNeighbors_wuMergeWorkunit - - subroutine print_wuMergeWorkunit(this) - class(wuMergeWorkunit) :: this - - write (*,*) "Warning, a call of this print()-method should not happen!" - end subroutine print_wuMergeWorkunit - - subroutine process_wuMergeWorkunit(this) - class(wuMergeWorkunit) :: this - - end subroutine process_wuMergeWorkunit - - subroutine unpack_wuMergeWorkunit(this) - class(wuMergeWorkunit) :: this - - end subroutine unpack_wuMergeWorkunit - - subroutine pack_wuMergeWorkunit(this) - class(wuMergeWorkunit) :: this - - end subroutine pack_wuMergeWorkunit - - subroutine free_wuMergeWorkunit(this) - class(wuMergeWorkunit) :: this - - call this%neededWUs%free() - end subroutine free_wuMergeWorkunit - - -end module wuMergeWorkunit_module diff --git a/extra/MyMPILib/ProjectConfig.cmake.in b/extra/MyMPILib/ProjectConfig.cmake.in deleted file mode 100644 index 952c8f0e..00000000 --- a/extra/MyMPILib/ProjectConfig.cmake.in +++ /dev/null @@ -1,9 +0,0 @@ -set (CMAKE_INSTALL_PREFIX ${CMAKE_BINARY_DIR}) - -set (INCLUDEDIRS_MPI_GNU /usr/lib/openmpi/include /usr/lib/openmpi/lib) -set (LINKDIRS_MPI_GNU /usr/lib /usr/lib/openmpi/lib) - -set (INCLUDEDIRS_MPI_INTEL /usr/local/openmpi-1.6.3-intel/include /usr/local/openmpi-1.6.3-intel/lib) -set (LINKDIRS_MPI_INTEL /usr/local/openmpi-1.6.3-intel/lib) - -set (MPE_PATH /afs/itp.tugraz.at/opt/mpe/1.3.0/) diff --git a/extra/MyMPILib/ProjectConfig.cmake.sample b/extra/MyMPILib/ProjectConfig.cmake.sample deleted file mode 100644 index 29e65f8c..00000000 --- a/extra/MyMPILib/ProjectConfig.cmake.sample +++ /dev/null @@ -1,9 +0,0 @@ -set (CMAKE_INSTALL_PREFIX ${CMAKE_SOURCE_DIR}) - -set (INCLUDEDIRS_MPI_GNU /usr/lib/openmpi/include /usr/lib/openmpi/lib) -set (LINKDIRS_MPI_GNU /usr/lib /usr/lib/openmpi/lib) - -set (INCLUDEDIRS_MPI_INTEL /usr/local/openmpi-1.6.3-intel/include /usr/local/openmpi-1.6.3-intel/lib) -set (LINKDIRS_MPI_INTEL /usr/local/openmpi-1.6.3-intel/lib) - -set (MPE_PATH /afs/itp.tugraz.at/opt/mpe/1.3.0/) diff --git a/extra/MyMPILib/Scripts/do_versioning.sh b/extra/MyMPILib/Scripts/do_versioning.sh deleted file mode 100755 index da9428b9..00000000 --- a/extra/MyMPILib/Scripts/do_versioning.sh +++ /dev/null @@ -1,24 +0,0 @@ -#!/bin/bash -GITHASH=`git rev-parse HEAD` -GITSHORTHASH=`git rev-parse --short HEAD` -GITCHANGEDFILES=`git diff-index --name-only HEAD` - -export GITSHORTHASH=$GITSHORTHASH - -echo "character(len=*), parameter :: MyMPILib_Version = '${GITHASH}'" > ./Internal/version.f90 -echo "Versioning MyMPILib..." - -if [ -n "$GITCHANGEDFILES" ]; then - echo 'character(len=*), parameter :: MyMPILib_Version_Additional = "WARNING, &' >> ./Internal/version.f90 - echo "&THERE ARE UNCOMMITTED CHANGES. Run may not be reproduceable: &" >> ./Internal/version.f90 - - while read -r line; do - echo "&${line} &" >> ./Internal/version.f90 - done <<< "$GITCHANGEDFILES" - echo '&"' >> ./Internal/version.f90 - -else - - echo 'character(len=*), parameter :: MyMPILib_Version_Additional = ""' >> ./Internal/version.f90 - -fi diff --git a/extra/MyMPILib/Specific/mpiprovider_module.f90 b/extra/MyMPILib/Specific/mpiprovider_module.f90 deleted file mode 100644 index 13ac884a..00000000 --- a/extra/MyMPILib/Specific/mpiprovider_module.f90 +++ /dev/null @@ -1,877 +0,0 @@ -!> Module for Singleton class mpiprovider -module mpiprovider_module - - !Include OpenMPI Libs - use mpi - - use commandline_parser_module - use configFile_parser_module - use wuList_module - use mpelog_module - use mylog_module - use packBuffer_module - - implicit none - - ! Some constants - integer, parameter :: wuTag = 1 - integer, parameter :: comTag = 2 - include "../Internal/version.f90" - - !> Storage structure for workunits. Belongs to the scheduler, but in the singleton each workunit has access to it - type :: globalSchedulerStorage - ! Main lists for workunit processing - type(workunitlist), allocatable :: waitingWorkunits !< Workunits which have not been sent to a client yet - type(workunitlist), allocatable :: pendingWorkunits !< Workunits which are already on clients - type(workunitlist), allocatable :: processedWorkunits !< Workunits which are completely done - - !> UID for next packable object - integer :: nextUID = 1 - - end type globalSchedulerStorage - - !> Singleton class for communicating with MPI - type, private :: mpiprovider - - !> Some MPI status variables - integer :: ierr, rank, numprocs - integer :: mpi_comm_clients - - !> Current procname of process - character(len=MPI_MAX_PROCESSOR_NAME) :: procname - - !> Activate/Deactivate MPE-profiling - logical :: mpe_log = .true. - - !> The buffer for packing and unpacking - type(packBuffer), public :: packBuffer - - !> Storage for workunit lists - type(globalSchedulerStorage) :: storage - - !> Define the initWorkunit - class(workunit), pointer :: initWU => null() - - !> Performance analysis - double precision :: wuTime = 0 - integer :: wuCount = 0 - double precision :: initTime = 0 - double precision :: deinitTime = 0 - double precision :: schedInitTime = 0 - double precision :: schedDeinitTime = 0 - integer :: balanceCount = 0 - double precision :: drTime = 0 - double precision :: drPackTime = 0 - integer :: drCount = 0 - - !> Benchmarks - integer :: meanDurWu !< How long should a workunit take (mean value) - integer :: meanDurInitWu !< How long should the creating of an initWU-value take (mean value) - real :: clientSpeed !< How fast should the client be (for simulating faster and slower clients) - contains - !> Constructor of mpiprovider - procedure :: init => init_mpiprovider - - !> Allocate send and receive buffer - procedure :: allocateBuffers => allocateBuffers_mpiprovider - - !> Destructor of mpiprovider - procedure :: deinit => deinit_mpiprovider - - !> Some getter functions for MPI status variables - procedure :: getProcName => getProcName_mpiprovider - procedure :: getRank => getRank_mpiprovider - procedure :: getNumProcs => getNumProcs_mpiprovider - procedure :: isParallel => isParallel_mpiprovider - procedure :: isMaster => isMaster_mpiprovider - - !> Wrapper commands - procedure :: send => send_mpiprovider - procedure :: recv => recv_mpiprovider - procedure :: isend => isend_mpiprovider - - procedure :: allgather_complex_1 => allgather_complex_1_mpiprovider - procedure :: allgather_complex_2 => allgather_complex_2_mpiprovider - procedure :: allgather_complex_3 => allgather_complex_3_mpiprovider - procedure :: allgather_complex_4 => allgather_complex_4_mpiprovider - procedure :: allgather_double_1 => allgather_double_1_mpiprovider - procedure :: allgather_double_2 => allgather_double_2_mpiprovider - procedure :: allgather_double_3 => allgather_double_3_mpiprovider - procedure :: allgather_double_4 => allgather_double_4_mpiprovider - procedure :: allgather_double_5 => allgather_double_5_mpiprovider - - - procedure :: allgather_inplace_complex_1 => allgather_inplace_complex_1_mpiprovider - procedure :: allgather_inplace_complex_2 => allgather_inplace_complex_2_mpiprovider - procedure :: allgather_inplace_complex_3 => allgather_inplace_complex_3_mpiprovider - procedure :: allgather_inplace_complex_4 => allgather_inplace_complex_4_mpiprovider - procedure :: allgather_inplace_complex_5 => allgather_inplace_complex_5_mpiprovider - procedure :: allgather_inplace_double_1 => allgather_inplace_double_1_mpiprovider - procedure :: allgather_inplace_double_2 => allgather_inplace_double_2_mpiprovider - procedure :: allgather_inplace_double_3 => allgather_inplace_double_3_mpiprovider - procedure :: allgather_inplace_double_4 => allgather_inplace_double_4_mpiprovider - procedure :: allgather_inplace_double_5 => allgather_inplace_double_5_mpiprovider - - generic, public :: allgather => allgather_complex_1, allgather_complex_2, & - allgather_complex_3, allgather_complex_4, & - allgather_double_1, allgather_double_2, & - allgather_double_3, allgather_double_4, & - allgather_double_5 - - generic, public :: allgather_inplace => & - allgather_inplace_complex_1, allgather_inplace_complex_2, & - allgather_inplace_complex_3, allgather_inplace_complex_4, & - allgather_inplace_complex_5, & - allgather_inplace_double_1, allgather_inplace_double_2, & - allgather_inplace_double_3, allgather_inplace_double_4, & - allgather_inplace_double_5 - - procedure :: barrier => barrier_mpiprovider - - !> For benchmark analysis - procedure :: randomSleep => randomSleep_mpiprovider - procedure, private :: initRandomSeed => initRandomSeed_mpiprovider - - end type mpiprovider - - !> Singleton - type(mpiprovider) :: mpro - -contains - - !> Constructor of mpiprovider - subroutine init_mpiprovider(this) - class(mpiprovider) :: this - character(len=MPI_MAX_PROCESSOR_NAME) :: procname - integer :: ierr, myid, namelen, numprocs - integer :: mpi_world_group, mpi_client_group - integer, dimension(1) :: group_excl_ranks - - ! Initialize MPI - call MPI_INIT(ierr) - if (ierr /= MPI_SUCCESS) then - write (*,*) "An error occurred in MPI_INIT", ierr - stop - end if - - ! Get number of processes - call MPI_COMM_SIZE(MPI_COMM_WORLD, numprocs, ierr) - if (ierr /= MPI_SUCCESS) then - write (*,*) "An error occurred in MPI_COMM_SIZE", ierr - stop - end if - - ! Get rank - call MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr) - if (ierr /= MPI_SUCCESS) then - write (*,*) "An error occurred in MPI_COMM_RANK", ierr - stop - end if - - ! Get processor name - call MPI_GET_PROCESSOR_NAME(procname, namelen, ierr) - if (ierr /= MPI_SUCCESS) then - write (*,*) "An error occurred in MPI_GET_PROCESSOR_NAME", ierr - stop - end if - - ! Create communicator for clients - if (numprocs > 1) then - group_excl_ranks(1) = 0 - call MPI_COMM_GROUP(MPI_COMM_WORLD, mpi_world_group, ierr) - call MPI_GROUP_EXCL(mpi_world_group, 1, group_excl_ranks, mpi_client_group, ierr) - call MPI_COMM_CREATE(MPI_COMM_WORLD, mpi_client_group, this%mpi_comm_clients, ierr) - call MPI_GROUP_FREE(mpi_client_group, ierr) - call MPI_GROUP_FREE(mpi_world_group, ierr) - end if - - ! Set local variables - this%ierr = ierr - this%procname = procname - this%rank = myid - this%numprocs = numprocs - - this%initTime = MPI_WTime() - - ! Initialize packBuffer - this%packBuffer = packBuffer() !New constructor possible since gfortran-4.7 - - ! Initialize random number generator - call this%initRandomSeed() - - ! Display state - write (*,"(A, I3, A, A10, A)") "MPI-Provider on process number ", myid, " on node ", trim(procname), " initialized!" - - ! Print version information - if (myid == 0) then - write (*,*) '' - write (*,*) "--------- MyMPILib Git Revision --------" - write (*,*) MyMPILib_Version - write (*,*) "----------------------------------------" - write (*,*) '' - if (len_trim(MyMPILib_Version_Additional) /= 0) then - write (*,*) "################################### MyMPILib Git Additional Information ##################################" - write (*,*) MyMPILib_Version_Additional - write (*,*) "##########################################################################################################" - write (*,*) '' - end if - end if - end subroutine init_mpiprovider - - !> Allocate the buffers, set normBufferSize before calling this function - subroutine allocateBuffers_mpiprovider(this, buffersize) - class(mpiprovider) :: this - integer :: buffersize - - ! Are buffers required or sequential mode? - if (this%numprocs > 1) then - if (this%getRank() == 0) write (*,*) "Allocating ", buffersize, "MBytes for the pack-buffers." - call this%packBuffer%allocateBuffers(buffersize) - end if - - end subroutine allocateBuffers_mpiprovider - - !> Destructor of mpiprovider - subroutine deinit_mpiprovider(this, showStats_opt) - class(mpiprovider) :: this - logical, optional :: showStats_opt - logical :: showStats - integer :: ierr - - call this%packBuffer%clear() - if (this%numprocs > 1) then - if (allocated(this%packBuffer%sendBuffer)) deallocate(this%packBuffer%sendBuffer) - if (allocated(this%packBuffer%recvBuffer)) deallocate(this%packBuffer%recvBuffer) - end if - - this%deinitTime = MPI_WTime() - - showStats = .true. - if (present(showStats_opt)) showStats = showStats_opt - - if (mpro%isMaster() .and. showStats) then - write (*,*) "Runtime analysis" - write (*,*) "----------------" - write (*,"(A, F16.2, A)") "Complete runtime: ", this%deinitTime - this%initTime, " s" - if (this%numprocs > 1) then - write (*,"(A, F16.2, A)") "Scheduler runtime: ", this%scheddeinitTime - this%schedinitTime, " s" - write (*,"(A, F16.2, A)") "Time before scheduling: ", this%schedInitTime - this%initTime, " s" - write (*,"(A, F16.2, A)") "Time after scheduling: ", this%deinitTime - this%scheddeinitTime, " s" - end if - end if - - call mpi_finalize(ierr) - this%ierr = ierr - - end subroutine deinit_mpiprovider - - !> Wrapper function for isend - function isend_mpiprovider(this, dest, tag, buffer) result(res) - class(mpiprovider) :: this - integer, intent(in) :: dest, tag - character(len=*) :: buffer - integer :: ierr - integer :: res - - call mlog%logEvent(mpe_e_sendA) - call MPI_ISEND(buffer, len(buffer), MPI_CHARACTER, dest, tag, MPI_COMM_WORLD, res, ierr) - if (ierr /= MPI_SUCCESS) then - write (*,*) "Error in MPI_ISEND", ierr - stop - end if - call mlog%logEvent(mpe_e_sendB, dest, tag) - end function isend_mpiprovider - - !> Wrapper function for allgather - subroutine allgather_double_1_mpiprovider(this, sendbuf, recvbuf) - class(mpiprovider) :: this - double precision :: sendbuf - double precision, dimension(:) :: recvbuf - integer :: sendcount, recvcount - integer :: ierr - - sendcount = 1 - recvcount = sendcount - - !write (*,*) "This is allgather_double_1_mpiprovider" - !write (*,*) "Sendbuf: ", sendbuf - !write (*,*) ubound_send, lbound_send - - call MPI_ALLGATHER(sendbuf, sendcount, MPI_DOUBLE, recvbuf, recvcount, MPI_DOUBLE, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - write (*,*) "Error in MPI_ALLGATHER", ierr - stop - end if - !write (*,*) "Recvbuf after gather: ", recvbuf - - end subroutine allgather_double_1_mpiprovider - - !> Wrapper function for allgather - subroutine allgather_double_2_mpiprovider(this, sendbuf, recvbuf) - class(mpiprovider) :: this - double precision, dimension(:) :: sendbuf - double precision, dimension(:,:) :: recvbuf - integer, dimension(1) :: lbound_send, ubound_send - integer, dimension(2) :: lbound_recv, ubound_recv - integer :: sendcount, recvcount - integer :: ierr - - lbound_send = lbound(sendbuf) - ubound_send = ubound(sendbuf) - lbound_recv = lbound(recvbuf) - ubound_recv = ubound(recvbuf) - - sendcount = ubound_send(1)-lbound_send(1)+1 - recvcount = sendcount - - ! write (*,*) ubound_send, lbound_send - - call MPI_ALLGATHER(sendbuf, sendcount, MPI_DOUBLE, recvbuf, recvcount, MPI_DOUBLE, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - write (*,*) "Error in MPI_ALLGATHER", ierr - stop - end if - end subroutine allgather_double_2_mpiprovider - - !> Wrapper function for allgather - subroutine allgather_double_3_mpiprovider(this, sendbuf, recvbuf) - class(mpiprovider) :: this - double precision, dimension(:,:) :: sendbuf - double precision, dimension(:,:,:) :: recvbuf - integer, dimension(2) :: lbound_send, ubound_send - integer, dimension(3) :: lbound_recv, ubound_recv - integer :: sendcount, recvcount - integer :: ierr - - lbound_send = lbound(sendbuf) - ubound_send = ubound(sendbuf) - lbound_recv = lbound(recvbuf) - ubound_recv = ubound(recvbuf) - - sendcount = (ubound_send(2)-lbound_send(2)+1) * (ubound_send(1)-lbound_send(1)+1) - recvcount = sendcount - - ! write (*,*) ubound_send, lbound_send - - call MPI_ALLGATHER(sendbuf, sendcount, MPI_DOUBLE, recvbuf, recvcount, MPI_DOUBLE, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - write (*,*) "Error in MPI_ALLGATHER", ierr - stop - end if - end subroutine allgather_double_3_mpiprovider - - !> Wrapper function for allgather - subroutine allgather_double_4_mpiprovider(this, sendbuf, recvbuf) - class(mpiprovider) :: this - double precision, dimension(:,:,:) :: sendbuf - double precision, dimension(:,:,:,:) :: recvbuf - integer, dimension(3) :: lbound_send, ubound_send - integer, dimension(4) :: lbound_recv, ubound_recv - integer :: sendcount, recvcount - integer :: ierr - - lbound_send = lbound(sendbuf) - ubound_send = ubound(sendbuf) - lbound_recv = lbound(recvbuf) - ubound_recv = ubound(recvbuf) - - sendcount = (ubound_send(3)-lbound_send(3)+1) * & - (ubound_send(2)-lbound_send(2)+1) * & - (ubound_send(1)-lbound_send(1)+1) - recvcount = sendcount - - !write (*,*) ubound_send, lbound_send - - call MPI_ALLGATHER(sendbuf, sendcount, MPI_DOUBLE, recvbuf, recvcount, MPI_DOUBLE, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - write (*,*) "Error in MPI_ALLGATHER", ierr - stop - end if - end subroutine allgather_double_4_mpiprovider - - !> Wrapper function for allgather - subroutine allgather_double_5_mpiprovider(this, sendbuf, recvbuf) - class(mpiprovider) :: this - double precision, dimension(:,:,:,:) :: sendbuf - double precision, dimension(:,:,:,:,:) :: recvbuf - integer, dimension(4) :: lbound_send, ubound_send - integer, dimension(5) :: lbound_recv, ubound_recv - integer :: sendcount, recvcount - integer :: ierr - - lbound_send = lbound(sendbuf) - ubound_send = ubound(sendbuf) - lbound_recv = lbound(recvbuf) - ubound_recv = ubound(recvbuf) - - sendcount = & - (ubound_send(4)-lbound_send(4)+1) * & - (ubound_send(3)-lbound_send(3)+1) * & - (ubound_send(2)-lbound_send(2)+1) * & - (ubound_send(1)-lbound_send(1)+1) - - recvcount = sendcount - - !write (*,*) ubound_send, lbound_send - - call MPI_ALLGATHER(sendbuf, sendcount, MPI_DOUBLE, recvbuf, recvcount, MPI_DOUBLE, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - write (*,*) "Error in MPI_ALLGATHER", ierr - stop - end if - end subroutine allgather_double_5_mpiprovider - - !> Wrapper function for allgather - subroutine allgather_complex_1_mpiprovider(this, sendbuf, recvbuf) - class(mpiprovider) :: this - double complex :: sendbuf - double complex, dimension(:) :: recvbuf - integer :: sendcount, recvcount - integer :: ierr - - sendcount = 1 - recvcount = sendcount - - !write (*,*) "This is allgather_double_1_mpiprovider" - !write (*,*) "Sendbuf: ", sendbuf - !write (*,*) ubound_send, lbound_send - - call MPI_ALLGATHER(sendbuf, sendcount, MPI_DOUBLE_COMPLEX, recvbuf, recvcount, MPI_DOUBLE_COMPLEX, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - write (*,*) "Error in MPI_ALLGATHER", ierr - stop - end if - !write (*,*) "Recvbuf after gather: ", recvbuf - - end subroutine allgather_complex_1_mpiprovider - - !> Wrapper function for allgather - subroutine allgather_complex_2_mpiprovider(this, sendbuf, recvbuf) - class(mpiprovider) :: this - double complex, dimension(:) :: sendbuf - double complex, dimension(:,:) :: recvbuf - integer, dimension(1) :: lbound_send, ubound_send - integer, dimension(2) :: lbound_recv, ubound_recv - integer :: sendcount, recvcount - integer :: ierr - - lbound_send = lbound(sendbuf) - ubound_send = ubound(sendbuf) - lbound_recv = lbound(recvbuf) - ubound_recv = ubound(recvbuf) - - sendcount = ubound_send(1)-lbound_send(1)+1 - recvcount = sendcount - - ! write (*,*) ubound_send, lbound_send - - call MPI_ALLGATHER(sendbuf, sendcount, MPI_DOUBLE_COMPLEX, recvbuf, recvcount, MPI_DOUBLE_COMPLEX, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - write (*,*) "Error in MPI_ALLGATHER", ierr - stop - end if - end subroutine allgather_complex_2_mpiprovider - - !> Wrapper function for allgather - subroutine allgather_complex_3_mpiprovider(this, sendbuf, recvbuf) - class(mpiprovider) :: this - double complex, dimension(:,:) :: sendbuf - double complex, dimension(:,:,:) :: recvbuf - integer, dimension(2) :: lbound_send, ubound_send - integer, dimension(3) :: lbound_recv, ubound_recv - integer :: sendcount, recvcount - integer :: ierr - - lbound_send = lbound(sendbuf) - ubound_send = ubound(sendbuf) - lbound_recv = lbound(recvbuf) - ubound_recv = ubound(recvbuf) - - sendcount = (ubound_send(2)-lbound_send(2)+1) * (ubound_send(1)-lbound_send(1)+1) - recvcount = sendcount - - ! write (*,*) ubound_send, lbound_send - - call MPI_ALLGATHER(sendbuf, sendcount, MPI_DOUBLE_COMPLEX, recvbuf, recvcount, MPI_DOUBLE_COMPLEX, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - write (*,*) "Error in MPI_ALLGATHER", ierr - stop - end if - end subroutine allgather_complex_3_mpiprovider - - !> Wrapper function for allgather - subroutine allgather_complex_4_mpiprovider(this, sendbuf, recvbuf) - class(mpiprovider) :: this - double complex, dimension(:,:,:) :: sendbuf - double complex, dimension(:,:,:,:) :: recvbuf - integer, dimension(3) :: lbound_send, ubound_send - integer, dimension(4) :: lbound_recv, ubound_recv - integer :: sendcount, recvcount - integer :: ierr - - lbound_send = lbound(sendbuf) - ubound_send = ubound(sendbuf) - lbound_recv = lbound(recvbuf) - ubound_recv = ubound(recvbuf) - - sendcount = (ubound_send(3)-lbound_send(3)+1) * (ubound_send(2)-lbound_send(2)+1) * (ubound_send(1)-lbound_send(1)+1) - recvcount = sendcount - - !write (*,*) ubound_send, lbound_send - - call MPI_ALLGATHER(sendbuf, sendcount, MPI_DOUBLE_COMPLEX, recvbuf, recvcount, MPI_DOUBLE_COMPLEX, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - write (*,*) "Error in MPI_ALLGATHER", ierr - stop - end if - end subroutine allgather_complex_4_mpiprovider - -!> BEGIN wrappers for allgather with MPI_IN_PLACE - - subroutine allgather_inplace_double_1_mpiprovider(this, recvbuf) - class(mpiprovider) :: this - double precision, dimension(:) :: recvbuf - integer :: recvcount - integer :: ierr - - recvcount = 1 - - call MPI_ALLGATHER(MPI_IN_PLACE, 0, MPI_DATATYPE_NULL, recvbuf, recvcount, & - MPI_DOUBLE, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - write (*,*) "Error in MPI_ALLGATHER", ierr - stop - end if - end subroutine allgather_inplace_double_1_mpiprovider - - subroutine allgather_inplace_double_2_mpiprovider(this, recvbuf) - class(mpiprovider) :: this - double precision, dimension(:,:) :: recvbuf - integer, dimension(2) :: lbound_recv, ubound_recv - integer :: recvcount - integer :: ierr - - lbound_recv = lbound(recvbuf) - ubound_recv = ubound(recvbuf) - - recvcount = ubound_recv(1)-lbound_recv(1)+1 - - call MPI_ALLGATHER(MPI_IN_PLACE, 0, MPI_DATATYPE_NULL, recvbuf, recvcount, & - MPI_DOUBLE, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - write (*,*) "Error in MPI_ALLGATHER", ierr - stop - end if - end subroutine allgather_inplace_double_2_mpiprovider - - subroutine allgather_inplace_double_3_mpiprovider(this, recvbuf) - class(mpiprovider) :: this - double precision, dimension(:,:,:) :: recvbuf - integer, dimension(3) :: lbound_recv, ubound_recv - integer :: recvcount - integer :: ierr - - lbound_recv = lbound(recvbuf) - ubound_recv = ubound(recvbuf) - - recvcount = (ubound_recv(2)-lbound_recv(2)+1) * & - (ubound_recv(1)-lbound_recv(1)+1) - - call MPI_ALLGATHER(MPI_IN_PLACE, 0, MPI_DATATYPE_NULL, recvbuf, recvcount, & - MPI_DOUBLE, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - write (*,*) "Error in MPI_ALLGATHER", ierr - stop - end if - end subroutine allgather_inplace_double_3_mpiprovider - - subroutine allgather_inplace_double_4_mpiprovider(this, recvbuf) - class(mpiprovider) :: this - double precision, dimension(:,:,:,:) :: recvbuf - integer, dimension(4) :: lbound_recv, ubound_recv - integer :: recvcount - integer :: ierr - - lbound_recv = lbound(recvbuf) - ubound_recv = ubound(recvbuf) - - recvcount = (ubound_recv(3)-lbound_recv(3)+1) * & - (ubound_recv(2)-lbound_recv(2)+1) * & - (ubound_recv(1)-lbound_recv(1)+1) - - call MPI_ALLGATHER(MPI_IN_PLACE, 0, MPI_DATATYPE_NULL, recvbuf, recvcount, & - MPI_DOUBLE, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - write (*,*) "Error in MPI_ALLGATHER", ierr - stop - end if - end subroutine allgather_inplace_double_4_mpiprovider - - subroutine allgather_inplace_double_5_mpiprovider(this, recvbuf) - class(mpiprovider) :: this - double precision, dimension(:,:,:,:,:) :: recvbuf - integer, dimension(5) :: lbound_recv, ubound_recv - integer :: recvcount - integer :: ierr - - lbound_recv = lbound(recvbuf) - ubound_recv = ubound(recvbuf) - - recvcount = (ubound_recv(4)-lbound_recv(4)+1) * & - (ubound_recv(3)-lbound_recv(3)+1) * & - (ubound_recv(2)-lbound_recv(2)+1) * & - (ubound_recv(1)-lbound_recv(1)+1) - - call MPI_ALLGATHER(MPI_IN_PLACE, 0, MPI_DATATYPE_NULL, recvbuf, recvcount, & - MPI_DOUBLE, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - write (*,*) "Error in MPI_ALLGATHER", ierr - stop - end if - end subroutine allgather_inplace_double_5_mpiprovider - - subroutine allgather_inplace_complex_1_mpiprovider(this, recvbuf) - class(mpiprovider) :: this - double complex, dimension(:) :: recvbuf - integer :: recvcount - integer :: ierr - - recvcount = 1 - - call MPI_ALLGATHER(MPI_IN_PLACE, 0, MPI_DATATYPE_NULL, recvbuf, recvcount, & - MPI_DOUBLE_COMPLEX, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - write (*,*) "Error in MPI_ALLGATHER", ierr - stop - end if - end subroutine allgather_inplace_complex_1_mpiprovider - - subroutine allgather_inplace_complex_2_mpiprovider(this, recvbuf) - class(mpiprovider) :: this - double complex, dimension(:,:) :: recvbuf - integer, dimension(2) :: lbound_recv, ubound_recv - integer :: recvcount - integer :: ierr - - lbound_recv = lbound(recvbuf) - ubound_recv = ubound(recvbuf) - - recvcount = ubound_recv(1)-lbound_recv(1)+1 - - call MPI_ALLGATHER(MPI_IN_PLACE, 0, MPI_DATATYPE_NULL, recvbuf, recvcount, & - MPI_DOUBLE_COMPLEX, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - write (*,*) "Error in MPI_ALLGATHER", ierr - stop - end if - end subroutine allgather_inplace_complex_2_mpiprovider - - subroutine allgather_inplace_complex_3_mpiprovider(this, recvbuf) - class(mpiprovider) :: this - double complex, dimension(:,:,:) :: recvbuf - integer, dimension(3) :: lbound_recv, ubound_recv - integer :: recvcount - integer :: ierr - - lbound_recv = lbound(recvbuf) - ubound_recv = ubound(recvbuf) - - recvcount = (ubound_recv(2)-lbound_recv(2)+1) * & - (ubound_recv(1)-lbound_recv(1)+1) - - call MPI_ALLGATHER(MPI_IN_PLACE, 0, MPI_DATATYPE_NULL, recvbuf, recvcount, & - MPI_DOUBLE_COMPLEX, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - write (*,*) "Error in MPI_ALLGATHER", ierr - stop - end if - end subroutine allgather_inplace_complex_3_mpiprovider - - subroutine allgather_inplace_complex_4_mpiprovider(this, recvbuf) - class(mpiprovider) :: this - double complex, dimension(:,:,:,:) :: recvbuf - integer, dimension(4) :: lbound_recv, ubound_recv - integer :: recvcount - integer :: ierr - - lbound_recv = lbound(recvbuf) - ubound_recv = ubound(recvbuf) - - recvcount = (ubound_recv(3)-lbound_recv(3)+1) * & - (ubound_recv(2)-lbound_recv(2)+1) * & - (ubound_recv(1)-lbound_recv(1)+1) - - call MPI_ALLGATHER(MPI_IN_PLACE, 0, MPI_DATATYPE_NULL, recvbuf, recvcount, & - MPI_DOUBLE_COMPLEX, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - write (*,*) "Error in MPI_ALLGATHER", ierr - stop - end if - end subroutine allgather_inplace_complex_4_mpiprovider - - subroutine allgather_inplace_complex_5_mpiprovider(this, recvbuf) - class(mpiprovider) :: this - double complex, dimension(:,:,:,:,:) :: recvbuf - integer, dimension(5) :: lbound_recv, ubound_recv - integer :: recvcount - integer :: ierr - - lbound_recv = lbound(recvbuf) - ubound_recv = ubound(recvbuf) - - recvcount = (ubound_recv(4)-lbound_recv(4)+1) * & - (ubound_recv(3)-lbound_recv(3)+1) * & - (ubound_recv(2)-lbound_recv(2)+1) * & - (ubound_recv(1)-lbound_recv(1)+1) - - call MPI_ALLGATHER(MPI_IN_PLACE, 0, MPI_DATATYPE_NULL, recvbuf, recvcount, & - MPI_DOUBLE_COMPLEX, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - write (*,*) "Error in MPI_ALLGATHER", ierr - stop - end if - end subroutine allgather_inplace_complex_5_mpiprovider - -!> END wrappers for allgather with MPI_IN_PLACE - - - subroutine barrier_mpiprovider(this) - class(mpiprovider) :: this - integer :: ierr - - call MPI_BARRIER(MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - write (*,*) "Error in MPI_BARRIER", ierr - stop - end if - end subroutine barrier_mpiprovider - - !> Wrapper function for send - subroutine send_mpiprovider(this, dest, tag, buffer) - class(mpiprovider) :: this - integer, intent(in) :: dest, tag - character(len=*) :: buffer - integer :: ierr - - call mlog%logEvent(mpe_e_sendA) - call MPI_SEND(buffer, len(buffer), MPI_CHARACTER, dest, tag, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - write (*,*) "Error in MPI_SEND", ierr - stop - end if - call mlog%logEvent(mpe_e_sendB, dest, tag) - end subroutine send_mpiprovider - - !> Wrapper function for receiving - subroutine recv_mpiprovider(this, source, tag, buffer) - class(mpiprovider) :: this - integer, intent(in) :: tag - integer, intent(out) :: source - character(len=4), intent(out) :: buffer - integer :: ierr - integer, dimension(MPI_STATUS_SIZE) :: rstatus - - call mlog%logEvent(mpe_e_recvA) - call MPI_RECV(buffer, 4, MPI_CHARACTER, MPI_ANY_SOURCE, tag, MPI_COMM_WORLD, rstatus, ierr) - if (ierr /= MPI_SUCCESS) then - write (*,*) "Error in MPI_RECV", ierr - stop - end if - source = rstatus(MPI_SOURCE) - call mlog%logEvent(mpe_e_recvB, source, tag) - - end subroutine recv_mpiprovider - - !> Get name of current process - function getProcName_mpiprovider(this) - class(mpiprovider) :: this - character(len=MPI_MAX_PROCESSOR_NAME) :: getProcName_mpiprovider - - getProcName_mpiprovider = trim(this%procname) - end function getProcName_mpiprovider - - !> Get current rank - function getRank_mpiprovider(this) - class(mpiprovider) :: this - integer :: getRank_mpiprovider - - getRank_mpiprovider = this%rank - end function getRank_mpiprovider - - !> Get number of all processes - function getNumProcs_mpiprovider(this) - class(mpiprovider) :: this - integer :: getNumProcs_mpiprovider - - getNumProcs_mpiprovider = this%numprocs - end function getNumProcs_mpiprovider - - function isParallel_mpiprovider(this) - class(mpiprovider) :: this - logical :: isParallel_mpiprovider - - isParallel_mpiprovider = this%numprocs > 1 - end function isParallel_mpiprovider - - function paraMode_mpiprovider(this) result(res) - class(mpiprovider) :: this - logical :: res - - res = (this%numprocs > 1) - end function paraMode_mpiprovider - - function isMaster_mpiprovider(this) result(res) - class(mpiprovider) :: this - logical :: res - - res = (this%getRank() == 0) - end function isMaster_mpiprovider - - !> Setting a different random seed for each rank - subroutine initrandomseed_mpiprovider(this) - class(mpiprovider) :: this - integer :: n - integer, dimension(:), allocatable :: seed - real :: r - - call random_seed(size = n) - allocate(seed(n)) - - ! Read a random seed from /dev/urandom - open(50, file="/dev/urandom", access='stream',form='UNFORMATTED') - read(50) seed - close(50) - - ! Set new seed - call random_seed(put = seed) - - deallocate(seed) - - call random_number(r) - if (this%getNumProcs() > 2) then - ! Used for 1. Benchmark - this%clientSpeed = 1.0*r + 0.5 - else - ! If running in linear mode, then always have the normal speed - this%clientSpeed = 1.0 - end if - !write (*,*) "Client performance of", mpro%getRank(), "=", this%clientSpeed - end subroutine initrandomseed_mpiprovider - - !> Simulates longer calculations for benchmarks - subroutine randomSleep_mpiprovider(this, meanTime) - class(mpiprovider) :: this - integer :: meanTime - integer :: waitTime - real :: r - - if (meanTime > 0) then - call random_number(r) - !write (*,*) r - waitTime = nint(2*r*meanTime * this%clientSpeed) - call sleep(waitTime) - - end if - end subroutine randomSleep_mpiprovider - -end module mpiprovider_module diff --git a/extra/MyMPILib/Specific/packBuffer_module.f90 b/extra/MyMPILib/Specific/packBuffer_module.f90 deleted file mode 100644 index 61cff1e3..00000000 --- a/extra/MyMPILib/Specific/packBuffer_module.f90 +++ /dev/null @@ -1,592 +0,0 @@ -module packBuffer_module - - use mpi - use mpelog_module - - implicit none - - INTEGER, PARAMETER :: longint = 8 - integer, parameter :: maxStrLen = 1024 - - - !> Class for send- or receive-buffer - type :: packBuffer - - !> Default send- and receive-buffer size - integer :: buffersize - - integer, allocatable, dimension(:) :: sendBuffer, recvBuffer - integer :: sendPos, recvPos - contains - - !> Constructor of class buffer - !procedure, nopass :: init => init_packBuffer - - !> Subroutines to write in the buffer - procedure :: add_mat2dim_int => add_mat2dim_int_packBuffer - procedure :: add_mat2dim_longint => add_mat2dim_longint_packBuffer - procedure :: add_mat2dim_real => add_mat2dim_real_packBuffer - procedure :: add_mat2dim_double => add_mat2dim_double_packBuffer - procedure :: add_int => add_int_packBuffer - procedure :: add_bool => add_bool_packBuffer - procedure :: add_real => add_real_packBuffer - procedure :: add_double => add_double_packBuffer - procedure :: add_string => add_string_packBuffer - procedure :: add_array_int => add_array_int_packBuffer - procedure :: add_array_longint => add_array_longint_packBuffer - procedure :: add_array_real => add_array_real_packBuffer - procedure :: add_array_double => add_array_double_packBuffer - - !> Generic add for pack buffer - generic, public :: add => add_mat2dim_longint, add_mat2dim_real, add_mat2dim_double, & - add_int, add_bool, add_real, add_double, add_string, & - add_array_int, add_array_double, add_array_real, add_array_longint, & - add_mat2dim_int - - !> Functions to read from the buffer - procedure :: get_int => get_int_packBuffer - procedure :: get_bool => get_bool_packBuffer - procedure :: get_mat2dim_real => get_mat2dim_real_packBuffer - procedure :: get_mat2dim_double => get_mat2dim_double_packBuffer - procedure :: get_mat2dim_int => get_mat2dim_int_packBuffer - procedure :: get_mat2dim_longint => get_mat2dim_longint_packBuffer - procedure :: get_real => get_real_packBuffer - procedure :: get_double => get_double_packBuffer - procedure :: get_string => get_string_packBuffer - procedure :: get_array_int => get_array_int_packBuffer - procedure :: get_array_longint => get_array_longint_packBuffer - procedure :: get_array_real => get_array_real_packBuffer - procedure :: get_array_double => get_array_double_packBuffer - - generic, public :: get => get_int, get_bool, get_mat2dim_real, get_mat2dim_double, get_mat2dim_longint, & - get_real, get_double, get_string, get_array_int, get_array_longint, & - get_array_real, get_array_double, get_mat2dim_int - - !> Clear the send buffer - procedure :: clear => clear_packBuffer - - !> Reset reading position of receive buffer - procedure :: resetPos => resetPos_packBuffer - - !> Wrapper functions for the MPI commands - procedure :: sendTo => sendTo_packBuffer - procedure :: isendTo => isendTo_packBuffer - procedure :: ssendTo => ssendTo_packBuffer - procedure :: receiveFrom => receiveFrom_packBuffer - - procedure :: allocateBuffers => allocateBuffers_packBuffer - end type packBuffer - - interface packBuffer - procedure init_packBuffer - end interface packBuffer - - contains - - !> Constructor of buffer - function init_packBuffer() result(obj) - type(packBuffer) :: obj - - call obj%resetPos() - end function init_packBuffer - - subroutine allocateBuffers_packBuffer(this, buffersize) - class(packBuffer) :: this - integer :: buffersize - - this%buffersize = buffersize * 1024 * 1024 / 4 - - allocate(this%sendBuffer(this%buffersize)) - allocate(this%recvBuffer(this%buffersize)) - - end subroutine allocateBuffers_packBuffer - - !> Reset read position from receive buffer - subroutine resetPos_packBuffer(this) - class(packBuffer):: this - - this%sendPos = 0 - this%recvPos = 0 - end subroutine resetPos_packBuffer - - !> Clear send buffer - subroutine clear_packBuffer(this) - class(packBuffer) :: this - - this%sendPos = 0 - end subroutine clear_packBuffer - - !> Add array to buffer - subroutine add_array_int_packBuffer(this, val) - implicit none - class(packBuffer) :: this - integer, dimension(:), allocatable :: val - integer :: ierr, ub, lb - - call MPI_Pack(allocated(val), 1, MPI_LOGICAL, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - if (allocated(val)) then - ub = ubound(val, 1) - lb = lbound(val, 1) - - call MPI_Pack(lb, 1, MPI_INTEGER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - call MPI_Pack(ub, 1, MPI_INTEGER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - call MPI_Pack(val, size(val), MPI_INTEGER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - end if - end subroutine add_array_int_packBuffer - - !> Add array to buffer - subroutine add_array_longint_packBuffer(this, val) - implicit none - class(packBuffer) :: this - integer(kind=longint), dimension(:), allocatable :: val - integer :: ierr, ub, lb - - call MPI_Pack(allocated(val), 1, MPI_LOGICAL, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - if (allocated(val)) then - ub = ubound(val, 1) - lb = lbound(val, 1) - - call MPI_Pack(lb, 1, MPI_INTEGER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - call MPI_Pack(ub, 1, MPI_INTEGER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - call MPI_Pack(val, size(val), MPI_INTEGER8, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - end if - end subroutine add_array_longint_packBuffer - - !> Add array to buffer - subroutine add_array_double_packBuffer(this, val) - implicit none - class(packBuffer) :: this - double precision, dimension(:), allocatable :: val - integer :: ierr, ub, lb - - call MPI_Pack(allocated(val), 1, MPI_LOGICAL, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - if (allocated(val)) then - ub = ubound(val, 1) - lb = lbound(val, 1) - - call MPI_Pack(lb, 1, MPI_INTEGER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - call MPI_Pack(ub, 1, MPI_INTEGER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - call MPI_Pack(val, size(val), MPI_DOUBLE_PRECISION, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - end if - end subroutine add_array_double_packBuffer - - !> Add array to buffer - subroutine add_array_real_packBuffer(this, val) - implicit none - class(packBuffer) :: this - real, dimension(:), allocatable :: val - integer :: ierr, ub, lb - - call MPI_Pack(allocated(val), 1, MPI_LOGICAL, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - if (allocated(val)) then - ub = ubound(val, 1) - lb = lbound(val, 1) - - call MPI_Pack(lb, 1, MPI_INTEGER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - call MPI_Pack(ub, 1, MPI_INTEGER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - call MPI_Pack(val, size(val), MPI_REAL, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - end if - end subroutine add_array_real_packBuffer - - - !> Add 2dim - matrix to buffer - subroutine add_mat2dim_real_packBuffer(this, val) - class(packBuffer) :: this - real, dimension(:,:), allocatable :: val - integer :: ierr, ub1, ub2, lb1, lb2 - - call MPI_Pack(allocated(val), 1, MPI_LOGICAL, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - if (allocated(val)) then - lb1 = lbound(val, 1) - ub1 = ubound(val, 1) - - lb2 = lbound(val, 2) - ub2 = ubound(val, 2) - - call MPI_Pack(lb1, 1, MPI_INTEGER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - call MPI_Pack(ub1, 1, MPI_INTEGER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - call MPI_Pack(lb2, 1, MPI_INTEGER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - call MPI_Pack(ub2, 1, MPI_INTEGER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - - call MPI_PACK(val, size(val), MPI_REAL, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - end if - end subroutine add_mat2dim_real_packBuffer - - !> Add 2dim - matrix to buffer - subroutine add_mat2dim_double_packBuffer(this, val) - class(packBuffer) :: this - double precision, dimension(:,:), allocatable :: val - integer :: ierr, ub1, ub2, lb1, lb2 - - call MPI_Pack(allocated(val), 1, MPI_LOGICAL, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - if (allocated(val)) then - lb1 = lbound(val, 1) - ub1 = ubound(val, 1) - - lb2 = lbound(val, 2) - ub2 = ubound(val, 2) - - call MPI_Pack(lb1, 1, MPI_INTEGER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - call MPI_Pack(ub1, 1, MPI_INTEGER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - call MPI_Pack(lb2, 1, MPI_INTEGER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - call MPI_Pack(ub2, 1, MPI_INTEGER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - - call MPI_PACK(val, size(val), MPI_DOUBLE_PRECISION, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - end if - - end subroutine add_mat2dim_double_packBuffer - - subroutine add_mat2dim_int_packBuffer(this, val) - class(packBuffer) :: this - integer, dimension(:,:), allocatable :: val - integer :: ub1, ub2, lb1, lb2, ierr - - call MPI_Pack(allocated(val), 1, MPI_LOGICAL, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - if (allocated(val)) then - lb1 = lbound(val, 1) - ub1 = ubound(val, 1) - - lb2 = lbound(val, 2) - ub2 = ubound(val, 2) - - call MPI_Pack(lb1, 1, MPI_INTEGER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - call MPI_Pack(ub1, 1, MPI_INTEGER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - call MPI_Pack(lb2, 1, MPI_INTEGER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - call MPI_Pack(ub2, 1, MPI_INTEGER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - - call MPI_PACK(val, size(val), MPI_INTEGER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - end if - end subroutine add_mat2dim_int_packBuffer - - subroutine add_mat2dim_longint_packBuffer(this, val) - class(packBuffer) :: this - integer(kind=longint), dimension(:,:), allocatable :: val - integer :: ub1, ub2, lb1, lb2, ierr - - call MPI_Pack(allocated(val), 1, MPI_LOGICAL, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - if (allocated(val)) then - lb1 = lbound(val, 1) - ub1 = ubound(val, 1) - - lb2 = lbound(val, 2) - ub2 = ubound(val, 2) - - call MPI_Pack(lb1, 1, MPI_INTEGER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - call MPI_Pack(ub1, 1, MPI_INTEGER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - call MPI_Pack(lb2, 1, MPI_INTEGER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - call MPI_Pack(ub2, 1, MPI_INTEGER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - - call MPI_PACK(val, size(val), MPI_INTEGER8, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - end if - end subroutine add_mat2dim_longint_packBuffer - - !> Add integer to buffer - subroutine add_int_packBuffer(this, val) - class(packBuffer) :: this - integer :: val - integer :: ierr - - call MPI_PACK(val, 1, MPI_INTEGER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - end subroutine add_int_packBuffer - - !> Add boolean to buffer - subroutine add_bool_packBuffer(this, val) - class(packBuffer) :: this - logical :: val - integer :: ierr - - call MPI_PACK(val, 1, MPI_LOGICAL, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - end subroutine add_bool_packBuffer - - !> Add real to buffer - subroutine add_real_packBuffer(this, val) - class(packBuffer) :: this - real :: val - integer :: ierr - - call MPI_PACK(val, 1, MPI_REAL, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - end subroutine add_real_packBuffer - - !> Add double precision to buffer - subroutine add_double_packBuffer(this, val) - class(packBuffer) :: this - double precision :: val - integer :: ierr - - call MPI_PACK(val, 1, MPI_DOUBLE_PRECISION, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - end subroutine add_double_packBuffer - - !> Add string to buffer - subroutine add_string_packBuffer(this, val) - class(packBuffer) :: this - character(len=*) :: val - integer :: ierr - - call MPI_PACK(val, maxStrLen, MPI_CHARACTER, this%sendBuffer, this%buffersize, this%sendPos, MPI_COMM_WORLD, ierr) - !write (*,*) "Adding string with length ", len(val), val - end subroutine add_string_packBuffer - - !> Unpack string from buffer - subroutine get_string_packBuffer(this, val) - class(packBuffer) :: this - character(len=maxStrLen) :: val - integer :: ierr - - call MPI_UNPACK(this%recvBuffer, this%buffersize, this%recvPos, val, maxStrLen, MPI_CHARACTER, MPI_COMM_WORLD, ierr) - - end subroutine get_string_packBuffer - - !> Unpack integer from buffer - subroutine get_int_packBuffer(this, val) - class(packBuffer) :: this - integer :: val, ierr - - call MPI_UNPACK(this%recvBuffer, this%buffersize, this%recvPos, val, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr) - - end subroutine get_int_packBuffer - - !> Unpack real from buffer - subroutine get_real_packBuffer(this, val) - class(packBuffer) :: this - real :: val - integer :: ierr - - call MPI_UNPACK(this%recvBuffer, this%buffersize, this%recvPos, val, 1, MPI_REAL, MPI_COMM_WORLD, ierr) - - end subroutine get_real_packBuffer - - !> Unpack double precision from buffer - subroutine get_double_packBuffer(this, val) - class(packBuffer) :: this - double precision :: val - integer :: ierr - - call MPI_UNPACK(this%recvBuffer, this%buffersize, this%recvPos, val, 1, MPI_DOUBLE_PRECISION, MPI_COMM_WORLD, ierr) - - end subroutine get_double_packBuffer - - !> Unpack boolean from buffer - subroutine get_bool_packBuffer(this, val) - class(packBuffer) :: this - logical :: val - integer :: ierr - - call MPI_UNPACK(this%recvBuffer, this%buffersize, this%recvPos, val, 1, MPI_LOGICAL, MPI_COMM_WORLD, ierr) - - end subroutine get_bool_packBuffer - - !> Unpack 2dim - matrix from buffer - subroutine get_mat2dim_real_packBuffer(this, val) - class(packBuffer) :: this - real, dimension(:,:), allocatable :: val - integer :: ierr, lb1, lb2, ub1, ub2 - logical :: alloc - - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, alloc, 1, MPI_LOGICAL, MPI_COMM_WORLD, ierr) - if (alloc) then - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, lb1, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr) - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, ub1, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr) - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, lb2, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr) - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, ub2, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr) - - allocate(val(lb1:ub1, lb2:ub2)) - call MPI_UNPACK(this%recvBuffer, this%buffersize, this%recvPos, val, & - (ub1-lb1+1)*(ub2-lb2+1), MPI_REAL, MPI_COMM_WORLD, ierr) - end if - end subroutine get_mat2dim_real_packBuffer - - !> Unpack 2dim - matrix from buffer - subroutine get_mat2dim_double_packBuffer(this, val) - class(packBuffer) :: this - double precision, dimension(:,:), allocatable :: val - integer :: ierr, lb1, lb2, ub1, ub2 - logical :: alloc - - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, alloc, 1, MPI_LOGICAL, MPI_COMM_WORLD, ierr) - if (alloc) then - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, lb1, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr) - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, ub1, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr) - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, lb2, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr) - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, ub2, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr) - - allocate(val(lb1:ub1, lb2:ub2)) - call MPI_UNPACK(this%recvBuffer, this%buffersize, this%recvPos, val, (ub1-lb1+1)*(ub2-lb2+1), & - MPI_DOUBLE_PRECISION, MPI_COMM_WORLD, ierr) - end if - - end subroutine get_mat2dim_double_packBuffer - - subroutine get_mat2dim_int_packBuffer(this, val) - class(packBuffer) :: this - integer, dimension(:,:), allocatable :: val - integer :: ierr, lb1, lb2, ub1, ub2 - logical :: alloc - - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, alloc, 1, MPI_LOGICAL, MPI_COMM_WORLD, ierr) - if (alloc) then - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, lb1, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr) - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, ub1, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr) - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, lb2, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr) - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, ub2, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr) - - allocate(val(lb1:ub1, lb2:ub2)) - - call MPI_UNPACK(this%recvBuffer, this%buffersize, this%recvPos, val, (ub1-lb1+1)*(ub2-lb2+1), & - MPI_INTEGER, MPI_COMM_WORLD, ierr) - end if - - end subroutine get_mat2dim_int_packBuffer - - subroutine get_mat2dim_longint_packBuffer(this, val) - class(packBuffer) :: this - integer(kind=longint), dimension(:,:), allocatable :: val - integer :: ierr, lb1, lb2, ub1, ub2 - logical :: alloc - - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, alloc, 1, MPI_LOGICAL, MPI_COMM_WORLD, ierr) - if (alloc) then - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, lb1, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr) - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, ub1, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr) - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, lb2, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr) - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, ub2, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr) - - allocate(val(lb1:ub1, lb2:ub2)) - - call MPI_UNPACK(this%recvBuffer, this%buffersize, this%recvPos, val, (ub1-lb1+1)*(ub2-lb2+1), & - MPI_INTEGER8, MPI_COMM_WORLD, ierr) - end if - - end subroutine get_mat2dim_longint_packBuffer - - subroutine get_array_int_packBuffer(this, val) - class(packBuffer) :: this - integer, dimension(:), allocatable :: val - integer :: lb, ub, ierr - logical :: alloc - - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, alloc, 1, MPI_LOGICAL, MPI_COMM_WORLD, ierr) - if (alloc) then - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, lb, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr) - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, ub, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr) - - allocate(val(lb:ub)) - call MPI_UNPACK(this%recvBuffer, this%buffersize, this%recvPos, val, ub-lb+1, MPI_INTEGER, MPI_COMM_WORLD, ierr) - end if - end subroutine get_array_int_packBuffer - - subroutine get_array_longint_packBuffer(this, val) - class(packBuffer) :: this - integer(kind=longint), dimension(:), allocatable :: val - integer :: lb, ub, ierr - logical :: alloc - - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, alloc, 1, MPI_LOGICAL, MPI_COMM_WORLD, ierr) - if (alloc) then - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, lb, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr) - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, ub, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr) - - allocate(val(lb:ub)) - call MPI_UNPACK(this%recvBuffer, this%buffersize, this%recvPos, val, ub-lb+1, MPI_INTEGER8, MPI_COMM_WORLD, ierr) - end if - - end subroutine get_array_longint_packBuffer - - subroutine get_array_real_packBuffer(this, val) - class(packBuffer) :: this - real, dimension(:), allocatable :: val - integer :: lb, ub, ierr - logical :: alloc - - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, alloc, 1, MPI_LOGICAL, MPI_COMM_WORLD, ierr) - if (alloc) then - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, lb, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr) - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, ub, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr) - - allocate(val(lb:ub)) - call MPI_UNPACK(this%recvBuffer, this%buffersize, this%recvPos, val, ub-lb+1, MPI_REAL, MPI_COMM_WORLD, ierr) - end if - - end subroutine get_array_real_packBuffer - - subroutine get_array_double_packBuffer(this, val) - class(packBuffer) :: this - double precision, dimension(:), allocatable :: val - integer :: lb, ub, ierr - logical :: alloc - - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, alloc, 1, MPI_LOGICAL, MPI_COMM_WORLD, ierr) - if (alloc) then - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, lb, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr) - call MPI_UnPack(this%recvBuffer, this%buffersize, this%recvPos, ub, 1, MPI_INTEGER, MPI_COMM_WORLD, ierr) - - allocate(val(lb:ub)) - call MPI_UNPACK(this%recvBuffer, this%buffersize, this%recvPos, val, ub-lb+1, MPI_DOUBLE_PRECISION, MPI_COMM_WORLD, ierr) - end if - - end subroutine get_array_double_packBuffer - - !> Warpper for sending and logging an event - subroutine sendTo_packBuffer(this, destRank, tag) - class(packBuffer) :: this - integer :: destRank, ierr, tag - - call mlog%logEvent(mpe_e_sendA) - call MPI_Send(this%sendBuffer, this%sendPos, MPI_PACKED, destRank, tag, MPI_COMM_WORLD, ierr) - call mlog%logEvent(mpe_e_sendB, destRank, tag) - - call this%clear() - - if (ierr /= 0) then - write (*,*) "ERROR in MPI_Send at sendTo_packBuffer", ierr - stop - end if - end subroutine sendTo_packBuffer - - !> Wrapper for SSend and logging - subroutine ssendTo_packBuffer(this, destRank, tag) - class(packBuffer) :: this - integer :: destRank, ierr, tag - - !write (*,*) "Sending buffer to ", destRank - - call mlog%logEvent(mpe_e_sendA) - call MPI_SSend(this%sendBuffer, this%sendPos, MPI_PACKED, destRank, tag, MPI_COMM_WORLD, ierr) - call mlog%logEvent(mpe_e_sendB, destRank, tag) - - call this%clear() - - if (ierr /= 0) then - write (*,*) "ERROR in MPI_SSend at ssendTo_packBuffer", ierr - stop - end if - end subroutine ssendTo_packBuffer - - !> Wrapper for ISend and logging - function isendTo_packBuffer(this, destRank, tag) result(res) - class(packBuffer) :: this - integer :: destRank, ierr, tag - integer :: res - - !write (*,*) "Sending buffer to ", destRank - call mlog%logEvent(mpe_e_sendA) - call MPI_ISend(this%sendBuffer, this%sendPos, MPI_PACKED, destRank, tag, MPI_COMM_WORLD, res, ierr) - call mlog%logEvent(mpe_e_sendB, destRank, tag) - end function isendTo_packBuffer - - !> Wrapper for receiving and loggins - subroutine receiveFrom_packBuffer(this, sourceRank, tag) - class(packBuffer) :: this - integer, intent(in) :: tag - integer :: sourceRank, ierr, source - integer, dimension(MPI_STATUS_SIZE) :: status - - !write (*,*) "Waiting for buffer from ", sourceRank - - call mlog%logEvent(mpe_e_recvA) - call MPI_Recv(this%recvBuffer, this%buffersize, MPI_PACKED, sourceRank, tag, MPI_COMM_WORLD, status, ierr) - source = status(MPI_SOURCE) - - call mlog%logEvent(mpe_e_recvB, source, tag) - end subroutine receiveFrom_packBuffer - -end module packBuffer_module diff --git a/extra/MyMPILib/Specific/scheduler_specific.f90 b/extra/MyMPILib/Specific/scheduler_specific.f90 deleted file mode 100644 index 6f1e17d7..00000000 --- a/extra/MyMPILib/Specific/scheduler_specific.f90 +++ /dev/null @@ -1,239 +0,0 @@ -! Specific part of the scheduler. This has to be overwritten for a specific problem. - -!> Needs to be overwritten to allocate specific workunits -function allocateSpecific_scheduler(this, wuType) result(res) - class(scheduler) :: this - character(len=maxStrLen) :: wuType - class(workunit), pointer :: res - - write (*,*) "ERROR, you have forgotten to set your work units in the function allocateSpecific ", wuType - stop -end function allocateSpecific_scheduler - -!> Needs to be overwritten when there is need for special mergeworkunits -function allocateSpecificMergeWU_scheduler(this) result(res) - class(scheduler) :: this - class(wuMergeWorkunit), pointer :: res - - write (*,*) "ERROR, you have forgotten to set your work units in the function allocateSpecificMergeWu " - stop -end function allocateSpecificMergeWU_scheduler - -!> Can be overwritten for special type of loadbalancing -subroutine loadBalancing_scheduler(this) - class(scheduler) :: this - integer :: k - - class(workunit), pointer :: selectWU - - ! If balancing is activated in config file - if (this%balance) then - - ! Iterate through all clients - do k = 1, mpro%getNumProcs()-1 - - ! Check if the client has no workunit at the moment - if (this%clientStats(k)%isReady) then - - ! Check if the client has nothing more to do - if (this%clientStats(k)%isDone) then - !write (*,*) "Client", k, "has nothing more to do." - call mpro%storage%waitingWorkunits%rewind() - - ! Search unprocessed workunit - do while (associated(mpro%storage%waitingWorkunits%currentElement)) - ! Tell the fortran compiler that the list contains workunits :-) - selectWU => mpro%storage%waitingWorkunits%getCurrent() - if (selectWU%balance) then - ! Search next free workunit - if ((selectWU%client /= k) .and. (.not. this%clientStats(selectWU%client)%isReady)) then - write (*,*) "------- Balancing", selectWU%uid, "from", selectWU%client, "to", k, " -------" - - ! Set client of the workunit to the client, which is done - call selectWU%setClient(k) - mpro%balanceCount = mpro%balanceCount + 1 - exit - end if - end if - - call mpro%storage%waitingWorkunits%gotoNext() - end do - else - ! If a client is ready, but not done yet, set it to done - ! If it will be done the next iteration of scheduler, it will get a balanced workunit - this%clientStats(k)%isDone = .true. - end if - end if - end do - end if - - -end subroutine loadBalancing_scheduler - -!> Check if workunits have to be created during runtime -subroutine checkIfClientDone_scheduler(this) - class(scheduler) :: this - integer :: k - type(wuDataRequester), pointer :: dr - class(wuMergeWorkunit), pointer :: wu - class(wuMergeWorkunit), pointer :: p - integer :: temp - - class(workunit), pointer :: selectWU => null() - class(workunit), pointer :: selectWU2 => null() - - do k = 1, mpro%getRank() -1 - this%clientStats(k)%localMerge = .false. - end do - - ! In the first iteration, local merges will be done, in the second iteration merges over different clients will be done - ! So, local merge has always higher priority - do k = 1, 2 - - call mpro%storage%processedWorkunits%rewind() - !if ((mpro%waitingWorkunits%getCount() == 0 .and. mpro%pendingWorkunits%getCount() == 0) .or. this%readyToMerge) then - - do while (associated(mpro%storage%processedWorkunits%currentElement)) - - selectWU => mpro%storage%processedWorkunits%getCurrent() - select type (q => selectWU) - class is (wuMergeWorkunit) - - !Do start with the second element - call mpro%storage%processedWorkunits%gotoNext() - - !Check if element was not already involved in a merge-process - if ((.not. q%isMerged) .and. (.not. q%doNotMerge)) then - nullify(p) - - ! Get needed object to merge - selectWU2 => mpro%storage%processedWorkunits%get(q%leftNeighbor, .false.) - if (associated(selectWU2)) then - - select type (selectWU2) - class is (wuMergeWorkunit) - p => selectWU2 - end select - - end if - - ! If found (object was already processed and is in processedWorkunits list) - if (associated(p)) then - - !write (*,*) "I would merge ", p%uid, q%uid, "on client", p%client - - !Check if clients have nothing to do - if (this%clientStats(p%client)%isReady .and. this%clientStats(q%client)%isReady .and. & - .not. this%clientStats(p%client)%isBlocked .and. .not. this%clientStats(q%client)%isBlocked) then - - ! Local merge has first priority ! - if ((k == 1) .and. (p%client == q%client)) then - - this%clientStats(p%client)%localMerge = .true. - - - wu => this%allocateMergeWU()!("wuExternalJoin") - !allocate(wu) - call wu%init() - wu%client = p%client - wu%resultUID = wu%uid - !wu%fracIndex = 0 - call wu%setNeighbors(p%leftNeighbor, q%rightNeighbor) - call wu%setMergeInfo(p%resultUID, q%resultUID) - - write (*,*) "Local merge on client", p%client, p%uid, q%uid - - if (p%druid /= -1) then - call wu%neededWUs%add(p%druid) - end if - - if (q%druid /= -1) then - call wu%neededWUs%add(q%druid) - end if - - call mpro%storage%waitingWorkunits%add(wu) - - call q%setMerged(.true.) - call this%repairNeighbors(p%uid, wu%leftNeighbor, wu%uid, wu%rightNeighbor) - call mpro%storage%processedWorkunits%rewind() - - - !call mpro%storage%waitingWorkunits%print() - else - if ((k == 2)) then - if (q%oldClient == -1) then - nullify(dr) - allocate(dr) - call dr%init() - dr%client = q%client - dr%dest = p%client !Right to left - dr%whichUID = q%uid - dr%fracIndex = 0 - call q%setOldClient(q%client) - !call dr%neededWUs%add(dr%whichUID) - call q%setClient(p%client) - - !this%clientStats(dr%dest)%isReady = .false. - this%clientStats(dr%dest)%isBlocked = .true. - !write (*,*) "Blocking client", dr%dest - - temp = dr%uid - call mpro%storage%waitingWorkunits%add(dr) - call p%setDrUID(temp) - call q%setDrUID(temp) - - call myLog%logCreateDR(dr%uid, dr%client, dr%dest, dr%whichUID) - write (*,*) "Creating dataRequester", dr%uid,"for client", dr%client, "UID=", & - dr%whichUID, "Dest=", dr%dest - !write (*,*) "Workunit status: ", q%doNotMerge, q%type, q%client - - end if - end if - end if - - !exit - else - - end if !Local merge ? - - end if ! Client are ready? - - else - cycle - end if ! workunit already merged - - ! Skip other workunits - class default - call mpro%storage%processedWorkunits%gotoNext() - - end select !Get only mergeWorkunits - - end do !Loop over processedWorkunits - - end do ! loop over k - -end subroutine checkIfClientDone_scheduler - - -!> Can be overwritten for special initial routines before starting the scheduling -subroutine initMaster_scheduler(this) - class(scheduler) :: this - -end subroutine initMaster_scheduler - -!> Can be overwritten for routines after the scheduling -subroutine summarize_scheduler(this) - class(scheduler) :: this - -end subroutine summarize_scheduler - -!> Linear mode of scheduler -subroutine initLinear_scheduler(this) - class(scheduler) :: this - -end subroutine initLinear_scheduler - -subroutine loadSettings_scheduler(this) - class(scheduler) :: this - -end subroutine loadSettings_scheduler diff --git a/extra/MyMPILib/Tools/commandline_parser_module.f90 b/extra/MyMPILib/Tools/commandline_parser_module.f90 deleted file mode 100644 index 447a92c0..00000000 --- a/extra/MyMPILib/Tools/commandline_parser_module.f90 +++ /dev/null @@ -1,38 +0,0 @@ -!> Module for class commandline_parser -module commandline_parser_module - - !> Class definition of commandline_parser - type commandline_parser - contains - procedure :: getInt => commandline_parser_getInt - end type commandline_parser - - !Singleton! - type(commandline_parser) :: comlineParser - -contains - - !> Get integer value from commandline arguments - function commandline_parser_getInt(this, argStr, defValue) result(res) - class(commandline_parser) :: this - character(len=*) :: argStr !< Key string - character(len=512) :: str - integer :: defValue !< Default value, if not defined - integer :: res - integer :: i, j - - res = defValue - - ! Read command line arguments - do i = 1, command_argument_count() - call get_command_argument(i, str) - j = index(str, argStr) - if (j > 0) then - read (str(j+len(argStr):),*) res - exit - end if - end do - - end function commandline_parser_getInt - -end module commandline_parser_module diff --git a/extra/MyMPILib/Tools/configFile_parser_module.f90 b/extra/MyMPILib/Tools/configFile_parser_module.f90 deleted file mode 100644 index ebe63461..00000000 --- a/extra/MyMPILib/Tools/configFile_parser_module.f90 +++ /dev/null @@ -1,104 +0,0 @@ -!> Module for class configFile_parser -module configFile_parser_module - implicit none - - integer, parameter :: maxCount = 100 - - !> Class definition of configFileParser - type :: configFileParser - character(len=256) :: filename !< Configfile name - integer :: fileHandle = 50 !< Fortran file handle - integer :: count !< Count of lines - character(80), dimension(maxCount) :: keysAndValues !< Storage for keys and values in the file - - contains - procedure :: readOut => readOut_configFileParser - procedure :: getInt => getInt_configFileParser - procedure, private :: searchKey => searchKey_configFileParser - - end type configFileParser - - ! Singleton ! - type(configFileParser) :: cfp - - contains - - !> Read out all keys and values from the config file - subroutine readOut_configFileParser(this) - class(configFileParser) :: this - integer :: f, stat - - write (*,*) "CONFIG FILE PARSER DEPRECATED! STOPPING PROGRAM" - stop - this%fileName = "./config.txt" - f = this%fileHandle - open(f, file=this%filename, action='read', iostat = stat) - !write (*,*) f, stat - - if (stat == 0) then - - this%count = 0 - do - read(f, '(A)', iostat=stat) this%keysAndValues(this%count + 1) - if (stat == 0) then - this%count = this%count + 1 - else - - exit - end if - end do - - if (stat > 0) then - write (*,*) "An error occured, while reading the config file", stat - stop - end if - - close(f) - - end if - end subroutine readOut_configFileParser - - !> Internal function to search a key - function searchKey_configFileParser(this, key, found) result(res) - class(configFileParser) :: this - character(len=*) :: key !< Key string to search - character(len=255) :: res - logical :: found !< Indicator, if found - integer :: i - - res = "" - found = .false. - - do i = 1, maxCount - if (index(trim(this%keysAndValues(i)), key // "=") == 1) then - res = this%keysAndValues(i) - found = .true. - exit - end if - end do - - end function searchKey_configFileParser - - !> Get integer value out of config file - function getInt_configFileParser(this, key, defaultVal) result(res) - class(configFileParser) :: this - character(len=*) :: key !< Key string - character(len=255) :: value - integer :: res - integer :: defaultVal !< Default value - integer :: i - logical :: found - - res = defaultVal - - value = this%searchKey(key ,found) - - if (found) then - read (value(len(key)+2:),*) res - !write (*,*) value(len(key)+2:) - !write (*,*) res - end if - - end function getInt_configFileParser - -end module configFile_parser_module diff --git a/extra/MyMPILib/Tools/intList_module.f90 b/extra/MyMPILib/Tools/intList_module.f90 deleted file mode 100644 index 4d2201ba..00000000 --- a/extra/MyMPILib/Tools/intList_module.f90 +++ /dev/null @@ -1,101 +0,0 @@ -!> List of integer values -module intlist_module - use list_module - implicit none - - type, extends(node) :: intnode - integer :: value - contains - procedure :: getUID => getUID_intnode - procedure :: set => set_intnode - procedure :: print => print_intnode - procedure :: free => free_intnode - end type intnode - - type, extends(list) :: intlist - - contains - procedure :: add => add_intlist - procedure :: get => get_intlist - procedure :: getCurrent => getCurrent_intlist - procedure :: relinkElementTo => relinkElementTo_intlist - end type intlist - -contains - - function getUID_intnode(this) result(res) - class(intnode) :: this - integer :: res - - res = this%value - end function getUID_intnode - - subroutine print_intnode(this) - class(intnode) :: this - - write (*,*) this%value - end subroutine print_intnode - - subroutine free_intnode(this) - class(intnode) :: this - - end subroutine free_intnode - - subroutine set_intnode(this, val) - class(intnode) :: this - integer :: val - - this%value = val - end subroutine set_intnode - - function get_intlist(this, index) result(res) - class(intList) :: this - integer :: index - class(node), pointer :: element - integer :: res - - res = 0 - element => this%getnode(index) - - if (associated(element)) then - select type (q => element) - class is (intnode) - res = q%value - end select - end if - end function get_intlist - - subroutine add_intlist(this, data) - class(intlist) :: this - integer :: data - class(intnode), pointer:: newNode - - allocate(intnode ::newNode) - call newNode%set(data) - call this%addNode(newNode) - end subroutine add_intlist - - subroutine relinkElementTo_intlist(this, newList, element) - class(intlist) :: this - type(intlist) :: newList - integer :: element - - !call element%print() - call newList%add(element) - call this%del(element, .false.) - end subroutine relinkElementTo_intlist - - function getCurrent_intList(this) result(res) - class(intList) :: this - integer :: res - - select type (q => this%currentElement) - type is (intnode) - res = q%value - class default - write (*,*) "FATAL ERROR: Integer-List: Something else than an integer-node in the list!" - res = -1 - end select - end function getCurrent_intList - -end module intlist_module diff --git a/extra/MyMPILib/Tools/list_module.f90 b/extra/MyMPILib/Tools/list_module.f90 deleted file mode 100644 index c175ce37..00000000 --- a/extra/MyMPILib/Tools/list_module.f90 +++ /dev/null @@ -1,426 +0,0 @@ -!> Module for classes list and node -module list_module - - implicit none - - !> Class node, for a node of the list - type :: node - class(node), pointer :: next => null() - class(node), pointer :: prev => null() - contains - procedure :: add => add_node - procedure :: free => free_node - - procedure :: print => print_node - procedure :: getNext => getNext_node - procedure :: getPrev => getPrev_node - - procedure :: getUID => getUID_node - procedure :: getSortIndex => getSortIndex_node - end type node - - !> Class list for storing all packable-objects - type list - class(node), pointer :: first => null() - class(node), pointer :: last => null() - class(node), pointer :: currentElement => null() - integer :: count = 0 - - !> If true, list will be sorted by sortIndex - logical :: sortList = .false. - contains - procedure, private :: changeRoot => changeRoot_list - - procedure :: init => init_list - procedure :: addnode => addnode_list - procedure :: del => del_list - - procedure :: print => print_list - procedure :: free => free_list - procedure :: getCount => getCount_list - - procedure :: getnode => getnode_list - procedure :: hasElement => hasElement_list - - procedure :: gotoNext => gotoNext_list - procedure :: gotoPrev => gotoPrev_list - procedure :: rewind => rewind_list - end type list - -contains - - !> ---------- NODE ------------- - - subroutine free_node(this) - class(node) :: this - - write (*,*) "List: Call of free_node should not happen, because it is designed to be inherited" - end subroutine free_node - - function getUID_node(this) - class(node) :: this - integer :: getUID_node - - getUID_node = -1 - write (*,*) "List: Call of getUID_node should not happen, because it is designed to be inherited" - end function getUID_node - - subroutine print_node(this) - class(node) :: this - write (*,*) "List: Call of print_node should not happen, because it is designed to be inherited" - end subroutine print_node - - function getSortIndex_node(this) result(res) - class(node) :: this - real :: res - - res = -1 - write (*,*) "List: Call of getSortIndex_node should not happen, because it is designed to be inherited" - end function getSortIndex_node - - function getNext_node(this) - class(node) :: this - class(node), pointer :: getNext_node - - getNext_node => null() - if (associated(this%next)) then - getNext_node => this%next - end if - end function getNext_node - - function getPrev_node(this) - class(node) :: this - class(node), pointer :: getPrev_node - - getPrev_node => null() - if (associated(this%prev)) then - getPrev_node => this%prev - end if - end function getPrev_node - - subroutine add_node(this, nextNode) - class(node) :: this - class(node), target :: nextNode - - this%next => nextNode - end subroutine add_node - - !-------- LIST --------- - - subroutine init_list(this) - class(list) :: this - - end subroutine init_list - - subroutine rewind_list(this) - class(list) :: this - - if (associated(this%first)) then - this%currentElement => this%first - else - this%currentElement => null() - end if - end subroutine rewind_list - - subroutine forward_list(this) - class(list) :: this - - if (associated(this%last)) then - this%currentElement => this%last - else - this%currentElement => null() - end if - end subroutine forward_list - - subroutine gotoNext_list(this) - class(list) :: this - - if (associated(this%currentElement)) then - this%currentElement => this%currentElement%getNext() - else - this%currentElement => this%first - end if - - end subroutine gotoNext_list - - subroutine gotoPrev_list(this) - class(list) :: this - - if (associated(this%currentElement)) then - this%currentElement => this%currentElement%getPrev() - if (.not. associated(this%currentElement)) then - this%currentElement => this%first - end if - else - this%currentElement => this%first - end if - end subroutine gotoPrev_list - - function hasElement_list(this, index) - class(list) :: this - integer :: index - - logical :: hasElement_list - class(node), pointer :: arrow - logical :: found - - found = .false. - - if (associated(this%first)) then - arrow => this%first - do while (associated(arrow)) - if (arrow%getUID() == index) then - found = .true. - exit - end if - arrow => arrow%getNext() - end do - - end if - - hasElement_list = found - end function hasElement_list - - function getnode_list(this, index, throwExcp) result(res) - class(list) :: this - integer :: index - logical, intent(in), optional :: throwExcp - - class(node), pointer :: arrow - class(node), pointer :: res - logical :: found, stopIfNotFound - - ! Decide if program should abort, if element is not in list - if (.not. present(throwExcp)) then - stopIfNotFound = .true. - else - stopIfNotFound = throwExcp - end if - - found = .false. - nullify(res) - arrow => this%first - - do while (associated(arrow)) - - if (arrow%getUID() == index) then - found = .true. - res => arrow - exit - end if - arrow => arrow%getNext() - end do - - if (.not. found) then - if (stopIfNotFound) then - write (*,*) "FATAL ERROR: Element ", index, "in list not found!" - call this%print() - stop - else - !write (*,*) "WARNING! Element ", index, " not found" - nullify(res) - end if - end if - - end function getnode_list - - subroutine changeRoot_list(this) - class(list) :: this - - this%first => getNext_node(this%first)!this%first%getNext() - - end subroutine changeRoot_list - - subroutine addnode_list(this, newNode) - class(list) :: this - class(node), target :: newNode - - class(node), pointer :: arrow, arrow2 - integer :: i - - if (associated(this%first)) then - if (.not. this%sortList) then - if (associated(this%last)) then - arrow => this%last - else - write (*,*) "An error occurred, last element of list not defined" - stop - end if - - !arrow => this%first - !do i = 1, this%count-1 - ! arrow => arrow%getNext() - !end do - arrow%next => newNode - newNode%prev => arrow - this%last => newNode - else - arrow => this%first - if (arrow%getSortIndex() > newNode%getSortIndex()) then - ! New Root - newNode%prev => null() - newNode%next => arrow - arrow%prev => newNode - this%first => newNode - else - do while (associated(arrow)) - if (arrow%getSortIndex() <= newNode%getSortIndex()) then - arrow2 => arrow - arrow => arrow%getNext() - else - arrow2 => arrow - arrow => arrow%getPrev() - - newNode%prev => arrow - newNode%next => arrow2 - - arrow%next => newNode - arrow2%prev => newNode - exit - end if - end do - if (.not. associated(arrow)) then - !New element should be the last element - newNode%prev => arrow2 - arrow2%next => newNode - end if - end if - end if - this%count = this%count + 1 - - else - this%first => newNode - this%last => newnode - this%count = 1 - end if - - end subroutine addnode_list - - subroutine del_list(this, index, freeMem) - class(list) :: this - integer :: index - class(node), pointer :: arrow, prev, next - logical, optional :: freeMem - - logical :: dealloc - - ! Decide if container element should be freed or not, after deletion of node - dealloc = .true. - if (present(freeMem)) then - dealloc = freeMem - end if - - if (associated(this%first)) then - arrow => this%first - do while (associated(arrow)) - if (arrow%getUID() /= index) then - arrow => arrow%getNext() - else - exit - end if - end do - - ! Decide behaviour of deletion of current element - !if (arrow%getUID() == this%currentElement%getUID()) then - ! this%currentElement - !end if - - prev => arrow%getPrev() - next => arrow%getNext() - - if (this%count > 1) then - if (associated(prev) .and. associated(next)) then - prev%next => next - next%prev => prev - else - if (associated(next)) then - next%prev => null() - this%first => next - else - prev%next => null() - end if - - if (associated(prev)) then - prev%next => null() - this%last => prev - else - next%prev => null() - end if - end if - else - this%first => null() - this%last => null() - !list empty - end if - - this%count = this%count - 1 - - if (associated(this%currentElement)) then - if (associated(this%currentElement%prev)) then - this%currentElement => this%currentElement%prev - else - if (associated(this%first)) then - this%currentElement => this%first - else - this%currentElement => null() - end if - end if - end if - - if (dealloc) then - call arrow%free() - end if - if (associated(arrow)) deallocate(arrow) - - end if - end subroutine del_list - - subroutine print_list(this) - class(list) :: this - class(node), pointer :: arrow - - if (associated(this%first)) then - arrow => this%first - - write (*,*) "Output of list:" - do while (associated(arrow)) - - call arrow%print() - arrow => arrow%getNext() - - end do - else - write (*,*) "" - end if - - end subroutine print_list - - subroutine free_list(this, freeMem) - class(list) :: this - logical, optional :: freeMem - logical :: dealloc - class(node), pointer :: arrow - integer :: i, id - - dealloc = .true. - if (present(freeMem)) then - dealloc = freeMem - end if - - do i = 1, this%count - arrow => this%first - id = arrow%getUID() - call this%del(id, dealloc) - - end do - - end subroutine free_list - - function getCount_list(this) - class(list) :: this - integer :: getCount_list - - getCount_list = this%count - end function getCount_list - -end module list_module diff --git a/extra/MyMPILib/Tools/mpelog_module.f90 b/extra/MyMPILib/Tools/mpelog_module.f90 deleted file mode 100644 index a23c3426..00000000 --- a/extra/MyMPILib/Tools/mpelog_module.f90 +++ /dev/null @@ -1,97 +0,0 @@ -!> Module for mpelog-class -module mpelog_module - - ! Include header file for MPE -#if defined(MPE_SUPPORT) - include "mpe_logf.h" -#endif - - !> Class mpelog - type :: mpelog - logical :: active = .false. - character(len = 8+4+1) :: startDateTime - contains - procedure :: init => init_mpelog - procedure :: deinit => deinit_mpelog - - procedure :: logEvent => logEvent_mpelog - end type mpelog - - integer :: mpe_e_sendA, mpe_e_sendB, mpe_e_recvA, mpe_e_recvB - integer :: mpe_e_compA, mpe_e_compB, mpe_e_createA, mpe_e_createB - integer :: mpe_e_busyA, mpe_e_busyB - - ! Singleton - type(mpelog) :: mlog - -contains - - !> Init the mpe mechanism and create event numbers - subroutine init_mpelog(this, myid) - class(mpelog) :: this - integer :: myid - character(8) :: date - character(10) :: time - -#if defined(MPE_SUPPORT) - if (this%active) then - ierr = MPE_Init_Log() - mpe_e_sendA = MPE_Log_get_event_number() - mpe_e_sendB = MPE_Log_get_event_number() - mpe_e_recvA = MPE_Log_get_event_number() - mpe_e_recvB = MPE_Log_get_event_number() - mpe_e_compA = MPE_Log_get_event_number() - mpe_e_compB = MPE_Log_get_event_number() - mpe_e_createA = MPE_Log_get_event_number() - mpe_e_createB = MPE_Log_get_event_number() - mpe_e_busyA = MPE_Log_get_event_number() - mpe_e_busyB = MPE_Log_get_event_number() - - if (myid == 0) then - ierr = MPE_Describe_state(mpe_e_sendA, mpe_e_sendB, "Sending", "red") - ierr = MPE_Describe_State(mpe_e_recvA, mpe_e_recvB, "Recvieving", "blue") - ierr = MPE_Describe_State(mpe_e_compA, mpe_e_compB, "Computing", "green") - ierr = MPE_Describe_State(mpe_e_createA, mpe_e_createB, "Creating", "lightgreen") - ierr = MPE_Describe_State(mpe_e_busyA, mpe_e_busyB, "Scheduler", "grey") - end if - - ierr = MPE_Start_log() - - call date_and_time(date, time) - this%startDateTime = date // "_" // time(1:4) - end if -#endif - end subroutine init_mpelog - - !> Stop logging and write file - subroutine deinit_mpelog(this) - class(mpelog) :: this -#if defined(MPE_SUPPORT) - if (this%active) then - ierr = MPE_Finish_Log("mpeProfile_" // this%startDateTime) - end if -#endif - end subroutine deinit_mpelog - - !> Log special event - subroutine logEvent_mpelog(this, ltype, opt1, opt2) - class(mpelog) :: this - integer, intent(in) :: ltype - integer, optional :: opt1, opt2 - - integer :: ierr -#if defined(MPE_SUPPORT) - - if (this%active) then - ierr = MPE_Log_Event(ltype, 0, "") - if (ltype == mpe_e_sendB) then - ierr = MPE_Log_Send(opt1, opt2, 0) - end if - if (ltype == mpe_e_recvB) then - ierr = MPE_Log_Receive(opt1, opt2, 0) - end if - end if -#endif - end subroutine logEvent_mpelog - -end module mpelog_module diff --git a/extra/MyMPILib/Tools/myLog_module.f90 b/extra/MyMPILib/Tools/myLog_module.f90 deleted file mode 100644 index 1e11fe61..00000000 --- a/extra/MyMPILib/Tools/myLog_module.f90 +++ /dev/null @@ -1,100 +0,0 @@ -!> Module for writing log-files -module myLog_module - use commandline_parser_module - - implicit none - - type myLogClass - - integer :: verbose = 0 - contains - - procedure :: init => init_mylogClass - procedure :: deinit => deinit_myLogClass - - procedure :: logRelinkWaitToPend => logRelinkWaitToPend_mylogClass - procedure :: logRelinkPendToProc => logRelinkPendToProc_mylogClass - procedure :: logSending => logSending_mylogClass - procedure :: logCreateDR => logCreateDR_myLogClass - - procedure, private :: getDateTime => getDateTime_myLogClass - - end type myLogClass - - ! Singleton - type(myLogClass) :: myLog - - -contains - - function getDateTime_myLogClass(this) result(res) - class(myLogClass) :: this - character(8) :: date - character(10) :: time - character(len=8+4+7) :: res - - call date_and_time(date, time) - res = date(7:8) // "." // date(5:6) // "." // date(1:4) // " "& - // time(1:2) // ":" // time(3:4) // ":" // time(5:6) - end function getDateTime_myLogClass - - subroutine init_mylogClass(this) - class(myLogClass) :: this - integer :: stat - character(8) :: date - character(10) :: time - call date_and_time(date, time) - - !this%verbose = comlineParser%getInt("-verbose=", 0) - - if (this%verbose > 0) then - open(10, file="myLog_" // date // "_" // time(1:4) // ".txt" , action='write', iostat=stat) - - write (10, *) "--- Begin logfile at", this%getDateTime(), "---" - - end if - end subroutine init_mylogClass - - subroutine deinit_myLogClass(this) - class(myLogClass) :: this - - if (this%verbose > 0) then - write (10,*) "--- End logfile at ", this%getDateTime(), "---" - close(10) - end if - end subroutine deinit_myLogClass - - subroutine logSending_myLogClass(this, source, dest, uid) - class(mylogClass) :: this - integer :: source, dest, uid - - if (this%verbose > 0) then - write (10, *) this%getDateTime(), ": Sending ", uid, " from ", source, " to ", dest - end if - end subroutine logSending_myLogClass - - subroutine logRelinkWaitToPend_mylogClass(this, uid) - class(mylogClass) :: this - integer :: uid - - if (this%verbose > 0) write (10, *) this%getDateTime(), ": Scheduler linking", uid, "to pending list" - end subroutine logRelinkWaitToPend_mylogClass - - subroutine logRelinkPendToProc_mylogClass(this, uid) - class(mylogClass) :: this - integer :: uid - - if (this%verbose > 0) write (10, *) this%getDateTime(), ": Scheduler linking", uid, "to processed list" - end subroutine logRelinkPendToProc_mylogClass - - subroutine logCreateDR_myLogClass(this, uid, source, dest, whichUID) - class(myLogClass) :: this - integer :: uid, source, dest, whichUID - - if (this%verbose > 0) write (10, *) this%getDateTime(), ": Create DataRequester (", uid, & - ") from client", source, " to client ", dest, " for WU " , whichUID - - end subroutine logCreateDR_myLogClass - - -end module myLog_module diff --git a/extra/MyMPILib/Tools/packableList_module.f90 b/extra/MyMPILib/Tools/packableList_module.f90 deleted file mode 100644 index c8942c73..00000000 --- a/extra/MyMPILib/Tools/packableList_module.f90 +++ /dev/null @@ -1,113 +0,0 @@ -!> List of packable objects -module packableList_module - - use list_module - use packable_module - - implicit none - - type, extends(node) :: packableNode - class(packable), pointer :: container => null() - contains - procedure :: getUID => getUID_packableNode - procedure :: set => set_packableNode - procedure :: print => print_packableNode - - procedure :: free => free_packableNode - end type packableNode - - type, extends(list) :: packableList - !class(packablenode), pointer :: first - !class(packablenode), pointer :: currentElement - contains - procedure :: add => add_packablelist - procedure :: get => get_packableList - - procedure :: getCurrent => getCurrent_packableList - procedure :: relinkElementTo => relinkElementTo_packablelist - end type packableList - -contains - - subroutine free_packableNode(this) - class(packableNode) :: this - - call this%container%free() - !if (associated(this%container)) deallocate(this%container) !Not working with ifort - end subroutine free_packableNode - - function get_packableList(this, index) - class(packableList) :: this - integer :: index - class(node), pointer :: element - class(packable), pointer :: get_packableList - - get_packableList => null() - element => this%getnode(index) - if (associated(element)) then - select type (q => element) - class is (packablenode) - get_packableList => q%container - end select - end if - end function get_packableList - - subroutine add_packableList(this, data) - class(packableList) :: this - class(packable) :: data - - class(packablenode), pointer :: newNode - - allocate(packableNode::newNode) - call newNode%set(this%count + 1, data) - call this%addNode(newNode) - end subroutine add_packableList - - subroutine relinkElementTo_packablelist(this, newList, element) - class(packablelist) :: this - type(packablelist) :: newList - class(packable) :: element - - !call element%print() - call newList%add(element) - call this%del(element%uid, .false.) - end subroutine relinkElementTo_packablelist - - function getCurrent_packableList(this) result(res) - class(packableList) :: this - class(packable), pointer :: res - - select type (q => this%currentElement) - type is (packableNode) - res => q%container - end select - end function getCurrent_packableList - - subroutine set_packablenode(this, idx, val) - class(packablenode) :: this - integer, intent(in) :: idx - class(packable), target :: val - - if (val%uid == -1) then - val%uid = idx - !write (*,*) "Element has no ID" - end if - this%container => val - - end subroutine set_packablenode - - function getUID_packableNode(this) - class(packableNode) :: this - integer :: getUID_packableNode - - getUID_packableNode = this%container%uid - end function getUID_packableNode - - subroutine print_packablenode(this) - class(packablenode) :: this - - !write (*,*) this%container%uid - call this%container%print() - end subroutine print_packablenode - -end module packableList_module diff --git a/extra/MyMPILib/Tools/wuList_module.f90 b/extra/MyMPILib/Tools/wuList_module.f90 deleted file mode 100644 index 0a7d7410..00000000 --- a/extra/MyMPILib/Tools/wuList_module.f90 +++ /dev/null @@ -1,169 +0,0 @@ -!> List of work units -module wuList_module - - use list_module - use workunit_module - - implicit none - - type, extends(node) :: workunitNode - class(workunit), pointer :: container => null() - contains - procedure :: getUID => getUID_workunitNode - procedure :: set => set_workunitNode - procedure :: print => print_workunitNode - - procedure :: free => free_workunitNode - - procedure :: getSortIndex => getSortIndex_workunitNode - end type workunitNode - - type, extends(list) :: workunitList - !class(workunitnode), pointer :: first - !class(workunitnode), pointer :: currentElement - contains - procedure :: add => add_workunitlist - procedure :: get => get_workunitList - procedure :: getCurrent => getCurrent_workunitList - procedure :: relinkElementTo => relinkElementTo_workunitlist - procedure :: moveListTo => moveListTo_workunitlist - end type workunitList - -contains - - function getSortIndex_workunitNode(this) result(res) - class(workunitNode) :: this - real :: res - - if (associated(this%container)) then - res = this%container%fracIndex - else - write (*,*) "ERROR in getSortIndex, Container of listnode is not associated" - stop - end if - end function getSortIndex_workunitNode - - subroutine free_workunitNode(this) - class(workunitNode) :: this - - if (associated(this%container)) then - call this%container%free() - end if - if (associated(this%container)) deallocate(this%container) !Not working with ifort - end subroutine free_workunitNode - - function get_workunitList(this, index, throwExcp) - class(workunitList) :: this - integer :: index - logical, optional :: throwExcp - class(node), pointer :: element - class(workunit), pointer :: get_workunitList - - get_workunitList => null() - if (present(throwExcp)) then - element => this%getnode(index, throwExcp) - else - element => this%getnode(index) - end if - if (associated(element)) then - select type (q => element) - class is (workunitnode) - get_workunitList => q%container - end select - end if - end function get_workunitList - - subroutine add_workunitList(this, data) - class(workunitList) :: this - class(workunit) :: data - type(workunitnode), pointer :: newNode - - this%sortList = .true. - allocate(newNode) - call newNode%set(this%count + 1, data) - call this%addNode(newNode) - end subroutine add_workunitList - - subroutine relinkElementTo_workunitlist(this, newList, element) - class(workunitlist) :: this - type(workunitlist) :: newList - class(workunit) :: element - - !call element%print() - call newList%add(element) - call this%del(element%uid, .false.) - end subroutine relinkElementTo_workunitlist - - subroutine moveListTo_workunitlist(this, newList) - class(workunitlist) :: this - type(workunitlist) :: newList - - class(node), pointer :: arrow - - arrow => this%first - do while (associated(arrow)) - arrow => this%first - select type (q => arrow) - type is (workunitNode) - call newList%add(q%container) - call this%del(q%container%uid, .false.) - end select - - end do - - call this%free() - !call newList%add(element) - !call this%del(element%uid, .false.) - end subroutine moveListTo_workunitlist - - function getCurrent_workunitList(this) result(res) - class(workunitList) :: this - class(workunit), pointer :: res - - !if (associated(this%currentElement)) then - - select type (q => this%currentElement) - type is (workunitNode) - if (associated(q%container)) then - res => q%container - else - write (*,*) "FATAL ERROR: Container nil!" - stop - end if - end select - - end function getCurrent_workunitList - - subroutine set_workunitnode(this, idx, val) - class(workunitnode) :: this - integer, intent(in) :: idx - class(workunit), target :: val - - if (val%uid == -1) then - val%uid = idx - !write (*,*) "Element has no ID" - end if - this%container => val - - end subroutine set_workunitnode - - function getUID_workunitNode(this) result(res) - class(workunitNode) :: this - integer :: res - - res = -1 - if (associated(this%container)) then - res = this%container%uid - else - write (*,*) "FATAL ERROR: Container not associated!" - end if - end function getUID_workunitNode - - subroutine print_workunitnode(this) - class(workunitnode) :: this - - !write (*,*) this%container%uid - call this%container%print() - end subroutine print_workunitnode - -end module wuList_module diff --git a/test/CMakeLists.txt b/test/CMakeLists.txt index f3dcf7cf..bdfad1fb 100644 --- a/test/CMakeLists.txt +++ b/test/CMakeLists.txt @@ -5,11 +5,8 @@ set (HDF5_TOOLS_LIB ${HDF5_TOOLS_LIB} hdf5_tools) set (MAGFIE_LIB ${MAGFIE_LIB} magfie) set(PROJLIBS /proj/plasma/Libs/ CACHE STRING "Common library path") -include_directories(${MPI_Fortran_INCLUDE_PATH}) include_directories(${PROJECT_SOURCE_DIR}/src/hdf5_tools) -include_directories(${PROJECT_SOURCE_DIR}/extra/MyMPILib) -include_directories(${MPI_Fortran_INCLUDE_PATH}) # Assumes previous include of hdf5_tools/CMakeLists.txt for find_package include_directories(${HDF5_INCLUDE_DIRS}) @@ -32,6 +29,16 @@ if (NOT Python_FOUND) message(FATAL_ERROR "Python interpreter required for GEQDSK scripts") endif() +set(LIBNEO_TEST_PYTHONPATH + "${CMAKE_SOURCE_DIR}/python:${CMAKE_BINARY_DIR}:${CMAKE_BINARY_DIR}/src/efit_to_boozer" +) + +function(set_libneo_python_test_environment test_name) + set_tests_properties(${test_name} PROPERTIES + ENVIRONMENT "PYTHONPATH=${LIBNEO_TEST_PYTHONPATH}" + ) +endfunction() + execute_process(COMMAND nf-config --flibs OUTPUT_VARIABLE NETCDF_LIBRARIES OUTPUT_STRIP_TRAILING_WHITESPACE) @@ -57,8 +64,6 @@ target_link_libraries(test_collision_freqs.x add_executable(test_arnoldi.x source/test_arnoldi.f90) target_link_libraries(test_arnoldi.x ${COMMON_LIBS} - MyMPILib - ${MPI_Fortran_LIBRARIES} ) add_executable(test_binsrc.x source/test_binsrc.f90) @@ -110,15 +115,6 @@ target_link_libraries(test_hdf5_tools.x ${HDF5_TOOLS_LIB} ) -add_executable(test_mympilib.x - source/test_mympilib.f90 - source/derived_scheduler_module.f90 -) -target_link_libraries(test_mympilib.x - MyMPILib - ${MPI_Fortran_LIBRARIES} -) - add_executable(test_system_utility.x source/test_system_utility.f90 ../src/local_rusage.c) @@ -286,6 +282,7 @@ endif() add_test(NAME test_arnoldi_setup COMMAND ${Python_EXECUTABLE} ${CMAKE_SOURCE_DIR}/test/source/setup_test_arnoldi.py) set_tests_properties(test_arnoldi_setup PROPERTIES WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR}) +set_libneo_python_test_environment(test_arnoldi_setup) add_test(NAME test_arnoldi COMMAND test_arnoldi.x) set_tests_properties(test_arnoldi PROPERTIES @@ -293,9 +290,6 @@ set_tests_properties(test_arnoldi PROPERTIES DEPENDS test_arnoldi_setup FAIL_REGULAR_EXPRESSION "STOP") -add_test(NAME test_mympilib - COMMAND test_mympilib.x) -set_tests_properties(test_mympilib PROPERTIES PASS_REGULAR_EXPRESSION "Derived initMaster") add_test(NAME test_system_utility COMMAND test_system_utility.x) set_tests_properties(test_system_utility PROPERTIES FAIL_REGULAR_EXPRESSION "WARNING: resource usage could not be determined.") @@ -305,12 +299,14 @@ add_test( COMMAND ${Python_EXECUTABLE} ${CMAKE_SOURCE_DIR}/test/scripts/setup_chartmap_volume.py --output-dir ${CMAKE_CURRENT_BINARY_DIR} ) +set_libneo_python_test_environment(setup_chartmap_volume) add_test( NAME setup_vmec_wout COMMAND ${Python_EXECUTABLE} ${CMAKE_SOURCE_DIR}/test/scripts/setup_vmec_wout.py --output-dir ${CMAKE_CURRENT_BINARY_DIR} ) +set_libneo_python_test_environment(setup_vmec_wout) add_test( NAME setup_vmec_chartmap_python @@ -321,6 +317,7 @@ set_tests_properties(setup_vmec_chartmap_python PROPERTIES WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR} DEPENDS setup_vmec_wout ) +set_libneo_python_test_environment(setup_vmec_chartmap_python) add_test( NAME validate_vmec_rho_lcfs_auto @@ -331,6 +328,7 @@ set_tests_properties(validate_vmec_rho_lcfs_auto PROPERTIES WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR} DEPENDS setup_vmec_wout ) +set_libneo_python_test_environment(validate_vmec_rho_lcfs_auto) add_test( NAME validate_vmec_map2disc_chartmap_boundary_python @@ -342,6 +340,7 @@ set_tests_properties(validate_vmec_map2disc_chartmap_boundary_python PROPERTIES WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR} DEPENDS setup_vmec_chartmap_python ) +set_libneo_python_test_environment(validate_vmec_map2disc_chartmap_boundary_python) add_test( NAME plot_vmec_map2disc_chartmap_boundary_python @@ -354,6 +353,7 @@ set_tests_properties(plot_vmec_map2disc_chartmap_boundary_python PROPERTIES WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR} DEPENDS setup_vmec_chartmap_python ) +set_libneo_python_test_environment(plot_vmec_map2disc_chartmap_boundary_python) add_test( NAME validate_vmec_map2disc_chartmap_boundary_cli @@ -365,6 +365,7 @@ set_tests_properties(validate_vmec_map2disc_chartmap_boundary_cli PROPERTIES WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR} DEPENDS setup_vmec_chartmap_python ) +set_libneo_python_test_environment(validate_vmec_map2disc_chartmap_boundary_cli) add_test( NAME plot_vmec_map2disc_chartmap_boundary_cli @@ -377,6 +378,7 @@ set_tests_properties(plot_vmec_map2disc_chartmap_boundary_cli PROPERTIES WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR} DEPENDS setup_vmec_chartmap_python ) +set_libneo_python_test_environment(plot_vmec_map2disc_chartmap_boundary_cli) add_test( NAME validate_vmec_map2disc_chartmap_boundary_python_padded @@ -389,6 +391,7 @@ set_tests_properties(validate_vmec_map2disc_chartmap_boundary_python_padded PROP WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR} DEPENDS setup_vmec_chartmap_python ) +set_libneo_python_test_environment(validate_vmec_map2disc_chartmap_boundary_python_padded) add_test( NAME plot_vmec_map2disc_chartmap_boundary_python_padded @@ -402,6 +405,7 @@ set_tests_properties(plot_vmec_map2disc_chartmap_boundary_python_padded PROPERTI WORKING_DIRECTORY ${CMAKE_CURRENT_BINARY_DIR} DEPENDS setup_vmec_chartmap_python ) +set_libneo_python_test_environment(plot_vmec_map2disc_chartmap_boundary_python_padded) add_test(NAME test_chartmap_coordinates COMMAND test_chartmap_coordinates.x) diff --git a/test/magfie/CMakeLists.txt b/test/magfie/CMakeLists.txt index d712cb63..7b4dafc3 100644 --- a/test/magfie/CMakeLists.txt +++ b/test/magfie/CMakeLists.txt @@ -6,7 +6,6 @@ target_link_libraries(test_coil_tools_biot_savart.x PRIVATE neo magfie util_for_test - MPI::MPI_Fortran ) # Register the test @@ -24,7 +23,6 @@ target_link_libraries(tilted_coil_fourier_modes.x PRIVATE neo magfie util_for_test - MPI::MPI_Fortran ) add_executable(tilted_coil_axis_field.x tilted_coil_axis_field.f90) diff --git a/test/source/derived_scheduler_module.f90 b/test/source/derived_scheduler_module.f90 deleted file mode 100644 index 51ddfb27..00000000 --- a/test/source/derived_scheduler_module.f90 +++ /dev/null @@ -1,19 +0,0 @@ -module derived_scheduler_module - use scheduler_module - - type, extends(scheduler) :: derived_scheduler - contains - procedure :: initMaster => derived_initMaster - procedure :: initLinear => derived_initMaster - end type derived_scheduler -contains - - subroutine derived_initMaster(this) - class(derived_scheduler) :: this - - associate(dummy => this) - end associate - - write(*,*) 'Derived initMaster' - end subroutine derived_initMaster -end module derived_scheduler_module diff --git a/test/source/test_arnoldi.f90 b/test/source/test_arnoldi.f90 index fe69e3c6..0f1b7b50 100644 --- a/test/source/test_arnoldi.f90 +++ b/test/source/test_arnoldi.f90 @@ -1,7 +1,4 @@ module test_arnoldi_mod -#ifdef PARALLEL - use mpiprovider_module, only : mpro -#endif use arnoldi, only: calc_ritz_eigenvalues, leigen,ngrow,tol,eigvecs use libneo_kinds, only : cdp implicit none @@ -42,10 +39,6 @@ end subroutine next_iteration subroutine run_test() integer :: i, j -#ifdef PARALLEL - call mpro%init() -#endif - open(1,file='amat.dat', action='read', status='old', iostat=ios) if (ios .ne. 0) stop 'Error while trying to open amat.dat' read(1,*) amat @@ -130,4 +123,4 @@ end module test_arnoldi_mod program test_arnoldi use test_arnoldi_mod call run_test() -end program test_arnoldi \ No newline at end of file +end program test_arnoldi diff --git a/test/source/test_mympilib.f90 b/test/source/test_mympilib.f90 deleted file mode 100644 index 35f3d6c4..00000000 --- a/test/source/test_mympilib.f90 +++ /dev/null @@ -1,7 +0,0 @@ -program test_mympilib - use derived_scheduler_module - - type(derived_scheduler) :: derived - - call derived%schedule() -end program test_mympilib