From ef90adbeb9ea742538ab510991df83472d7a9693 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 3 Jun 2021 17:09:39 +0100 Subject: [PATCH 01/40] Remove arpack (no longer needed) and use openmpi as default mpi for MKL when using gfortran --- makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/makefile b/makefile index d333d9f..80f5120 100644 --- a/makefile +++ b/makefile @@ -53,7 +53,7 @@ else ifeq ($(strip $(COMPILER)),gfortran) LAPACK = -L${MKLROOT}/lib/intel64 -Wl,--no-as-needed -lmkl_gf_lp64 -lmkl_gnu_thread -lmkl_core -lgomp -lpthread -lm -ldl ifdef USE_MPI - LAPACK += -lmkl_blacs_intelmpi_lp64 -lmkl_scalapack_lp64 + LAPACK += -lmkl_blacs_openmpi_lp64 -lmkl_scalapack_lp64 endif else $(error Compiler option "$(COMPILER)" not defined.) From 944fe6a880aaba49b1e43c7c2f76a635ef353668 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 17 Jun 2021 16:37:45 +0100 Subject: [PATCH 02/40] Add pFUnit as git submodule --- .gitmodules | 3 +++ pFUnit | 1 + 2 files changed, 4 insertions(+) create mode 100644 .gitmodules create mode 160000 pFUnit diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..9b75f35 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "pFUnit"] + path = pFUnit + url = git@github.com:Goddard-Fortran-Ecosystem/pFUnit.git diff --git a/pFUnit b/pFUnit new file mode 160000 index 0000000..bc4de1f --- /dev/null +++ b/pFUnit @@ -0,0 +1 @@ +Subproject commit bc4de1fa39f1eb8843cb60e2f418787301dde06e From 86821fea2b66ce80eaba6be2d3dbba42c1994454 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 17 Jun 2021 16:49:05 +0100 Subject: [PATCH 03/40] Move pfunit to lib folder --- .gitmodules | 4 ++-- pFUnit => lib/pFUnit | 0 2 files changed, 2 insertions(+), 2 deletions(-) rename pFUnit => lib/pFUnit (100%) diff --git a/.gitmodules b/.gitmodules index 9b75f35..19d94f0 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,3 +1,3 @@ -[submodule "pFUnit"] - path = pFUnit +[submodule "lib/pFUnit"] + path = lib/pFUnit url = git@github.com:Goddard-Fortran-Ecosystem/pFUnit.git diff --git a/pFUnit b/lib/pFUnit similarity index 100% rename from pFUnit rename to lib/pFUnit From ee37c907f754899925f482392c4c2e8704661a4a Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 17 Jun 2021 16:57:33 +0100 Subject: [PATCH 04/40] Add makefile recipe for building and installing pfunit --- makefile | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/makefile b/makefile index 80f5120..46990eb 100644 --- a/makefile +++ b/makefile @@ -70,6 +70,7 @@ endif ## LIBRARIES ################################################################################ +PFUNIT_DIR = lib/pFUnit WIGXJPF_DIR = wigxjpf-1.5 WIGXJPF_LIB = $(WIGXJPF_DIR)/lib/libwigxjpf.a LIB = $(LAPACK) $(LIBS) $(WIGXJPF_LIB) $(ARPACK) @@ -100,7 +101,7 @@ VPATH = $(SRCDIR):$(user_pot_dir):$(OBJDIR) ## TARGETS ################################################################################ -.PHONY: all, clean, cleanall, tarball, checkin, test +.PHONY: all, clean, cleanall, tarball, checkin, test, install-pfunit all: $(BINDIR) $(OBJDIR) $(BINDIR)/$(EXE) @@ -123,6 +124,13 @@ ifneq ($(BINDIR),.) mkdir -p $(BINDIR) endif +install-pfunit: + git submodule init # Make sure we have pfunit + mkdir $(PFUNIT_DIR)/build + cd $(PFUNIT_DIR)/build && cmake .. + $(MAKE) -C $(PFUNIT_DIR)/build + $(MAKE) -C $(PFUNIT_DIR)/build install + clean: rm -rf $(BINDIR)/$(EXE) $(OBJDIR)/*.mod $(OBJDIR)/*.o From 02f19bde605f0dcea1114c42d5485e90dda874d3 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 17 Jun 2021 17:02:37 +0100 Subject: [PATCH 05/40] Add TARGET var to makefile to help cleanup --- makefile | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/makefile b/makefile index 46990eb..93a593e 100644 --- a/makefile +++ b/makefile @@ -83,6 +83,7 @@ BINDIR=. SRCDIR=. OBJDIR=. user_pot_dir=. +TARGET=$(BINDIR)/$(EXE) SRCS := timer.f90 accuracy.f90 diag.f90 dipole.f90 extfield.f90 fields.f90 fwigxjpf.f90 input.f90 kin_xy2.f90 lapack.f90 \ me_bnd.f90 me_numer.f90 me_rot.f90 me_str.f90 \ @@ -103,12 +104,12 @@ VPATH = $(SRCDIR):$(user_pot_dir):$(OBJDIR) .PHONY: all, clean, cleanall, tarball, checkin, test, install-pfunit -all: $(BINDIR) $(OBJDIR) $(BINDIR)/$(EXE) +all: $(TARGET) -%.o : %.f90 +%.o : $(OBJDIR) %.f90 $(FOR) -c $(FFLAGS) $(CPPFLAGS) -o $(OBJDIR)/$@ $< -$(BINDIR)/$(EXE): $(OBJS) $(WIGXJPF_LIB) +$(BINDIR)/$(EXE): $(BINDIR) $(OBJS) $(WIGXJPF_LIB) $(FOR) $(FFLAGS) -o $@ $(addprefix $(OBJDIR)/,$(OBJS)) $(LIB) $(WIGXJPF_LIB): @@ -132,7 +133,7 @@ install-pfunit: $(MAKE) -C $(PFUNIT_DIR)/build install clean: - rm -rf $(BINDIR)/$(EXE) $(OBJDIR)/*.mod $(OBJDIR)/*.o + rm -rf $(TARGET) $(OBJDIR)/*.mod $(OBJDIR)/*.o cleanall: clean $(MAKE) -C $(WIGXJPF_DIR) clean @@ -143,7 +144,7 @@ tarball: checkin: ci -l Makefile *.f90 -test: $(BINDIR)/$(EXE) +test: $(TARGET) cd test; ./run_regression_tests.sh ################################################################################ From 6a2dd67faeedff9cbf5409ee9e6200b6c6638e67 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 17 Jun 2021 17:21:01 +0100 Subject: [PATCH 06/40] Move regression tests to their own directory within test to make room for unit tests --- makefile | 13 +++++++++---- test/{ => regression}/compare_results.py | 0 test/{ => regression}/download_benchmarks.sh | 0 test/{ => regression}/run_regression_tests.sh | 2 +- .../scripts/H2CO/compare_results.sh | 0 test/{ => regression}/scripts/H2CO/run_benchmark.sh | 0 6 files changed, 10 insertions(+), 5 deletions(-) rename test/{ => regression}/compare_results.py (100%) rename test/{ => regression}/download_benchmarks.sh (100%) rename test/{ => regression}/run_regression_tests.sh (97%) rename test/{ => regression}/scripts/H2CO/compare_results.sh (100%) rename test/{ => regression}/scripts/H2CO/run_benchmark.sh (100%) diff --git a/makefile b/makefile index 93a593e..70f0650 100644 --- a/makefile +++ b/makefile @@ -104,9 +104,9 @@ VPATH = $(SRCDIR):$(user_pot_dir):$(OBJDIR) .PHONY: all, clean, cleanall, tarball, checkin, test, install-pfunit -all: $(TARGET) +all: $(OBJDIR) $(TARGET) -%.o : $(OBJDIR) %.f90 +%.o : %.f90 $(FOR) -c $(FFLAGS) $(CPPFLAGS) -o $(OBJDIR)/$@ $< $(BINDIR)/$(EXE): $(BINDIR) $(OBJS) $(WIGXJPF_LIB) @@ -144,8 +144,13 @@ tarball: checkin: ci -l Makefile *.f90 -test: $(TARGET) - cd test; ./run_regression_tests.sh +test: regression-tests unit-tests + +regression-tests: $(TARGET) + cd test/regression; ./run_regression_tests.sh + +unit-tests: $(TARGET) + $(MAKE) -C test/unit ################################################################################ ## DEPENDENCIES diff --git a/test/compare_results.py b/test/regression/compare_results.py similarity index 100% rename from test/compare_results.py rename to test/regression/compare_results.py diff --git a/test/download_benchmarks.sh b/test/regression/download_benchmarks.sh similarity index 100% rename from test/download_benchmarks.sh rename to test/regression/download_benchmarks.sh diff --git a/test/run_regression_tests.sh b/test/regression/run_regression_tests.sh similarity index 97% rename from test/run_regression_tests.sh rename to test/regression/run_regression_tests.sh index 53b0728..cd9e84c 100755 --- a/test/run_regression_tests.sh +++ b/test/regression/run_regression_tests.sh @@ -3,7 +3,7 @@ set -e exe_name=j-trove.x -exe=../$exe_name +exe=../../$exe_name nproc=1 # Check exe is present diff --git a/test/scripts/H2CO/compare_results.sh b/test/regression/scripts/H2CO/compare_results.sh similarity index 100% rename from test/scripts/H2CO/compare_results.sh rename to test/regression/scripts/H2CO/compare_results.sh diff --git a/test/scripts/H2CO/run_benchmark.sh b/test/regression/scripts/H2CO/run_benchmark.sh similarity index 100% rename from test/scripts/H2CO/run_benchmark.sh rename to test/regression/scripts/H2CO/run_benchmark.sh From f86f92479bd231f11b1ad62dbc7ec2e3f788f915 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Mon, 21 Jun 2021 13:45:41 +0100 Subject: [PATCH 07/40] Remove && operator in makefile to match other similar lines --- makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/makefile b/makefile index 70f0650..2faace3 100644 --- a/makefile +++ b/makefile @@ -128,7 +128,7 @@ endif install-pfunit: git submodule init # Make sure we have pfunit mkdir $(PFUNIT_DIR)/build - cd $(PFUNIT_DIR)/build && cmake .. + cd $(PFUNIT_DIR)/build; cmake .. $(MAKE) -C $(PFUNIT_DIR)/build $(MAKE) -C $(PFUNIT_DIR)/build install From 543d9410916b07332f91954e634ab682e0f6f946 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Tue, 22 Jun 2021 10:17:10 +0100 Subject: [PATCH 08/40] Add simple example unit tests --- makefile | 12 ++++-- test/unit/.gitignore | 2 + test/unit/makefile | 16 +++++++ test/unit/test_simple.pf | 47 +++++++++++++++++++++ test/unit/test_simple_fixture.pf | 71 ++++++++++++++++++++++++++++++++ 5 files changed, 145 insertions(+), 3 deletions(-) create mode 100644 test/unit/.gitignore create mode 100644 test/unit/makefile create mode 100644 test/unit/test_simple.pf create mode 100644 test/unit/test_simple_fixture.pf diff --git a/makefile b/makefile index 2faace3..8bb5b4b 100644 --- a/makefile +++ b/makefile @@ -34,7 +34,7 @@ ifeq ($(strip $(COMPILER)),intel) # gfortran ########## else ifeq ($(strip $(COMPILER)),gfortran) - FOR = gfortran + FC = gfortran FFLAGS = -cpp -std=gnu -fopenmp -march=native -ffree-line-length-512 -fcray-pointer -I$(OBJDIR) -J$(OBJDIR) GCC_VERSION_GT_10 := $(shell expr `gcc -dumpversion | cut -f1 -d.` \>= 10) @@ -66,6 +66,8 @@ ifdef USE_MPI FFLAGS += -DTROVE_USE_MPI_ endif +export FC + ################################################################################ ## LIBRARIES ################################################################################ @@ -107,10 +109,10 @@ VPATH = $(SRCDIR):$(user_pot_dir):$(OBJDIR) all: $(OBJDIR) $(TARGET) %.o : %.f90 - $(FOR) -c $(FFLAGS) $(CPPFLAGS) -o $(OBJDIR)/$@ $< + $(FC) -c $(FFLAGS) $(CPPFLAGS) -o $(OBJDIR)/$@ $< $(BINDIR)/$(EXE): $(BINDIR) $(OBJS) $(WIGXJPF_LIB) - $(FOR) $(FFLAGS) -o $@ $(addprefix $(OBJDIR)/,$(OBJS)) $(LIB) + $(FC) $(FFLAGS) -o $@ $(addprefix $(OBJDIR)/,$(OBJS)) $(LIB) $(WIGXJPF_LIB): $(MAKE) -C $(WIGXJPF_DIR) @@ -134,6 +136,7 @@ install-pfunit: clean: rm -rf $(TARGET) $(OBJDIR)/*.mod $(OBJDIR)/*.o + $(MAKE) -C test/unit clean cleanall: clean $(MAKE) -C $(WIGXJPF_DIR) clean @@ -147,10 +150,13 @@ checkin: test: regression-tests unit-tests regression-tests: $(TARGET) + echo "Running regression tests" cd test/regression; ./run_regression_tests.sh unit-tests: $(TARGET) $(MAKE) -C test/unit + echo "Running unit tests" + test/unit/test_simple ################################################################################ ## DEPENDENCIES diff --git a/test/unit/.gitignore b/test/unit/.gitignore new file mode 100644 index 0000000..873ee29 --- /dev/null +++ b/test/unit/.gitignore @@ -0,0 +1,2 @@ +*.inc +*.F90 diff --git a/test/unit/makefile b/test/unit/makefile new file mode 100644 index 0000000..2610138 --- /dev/null +++ b/test/unit/makefile @@ -0,0 +1,16 @@ +include ../../lib/pFUnit/build/PFUNIT.mk + +all: test_simple + +%.o : %.F90 + $(FC) -c $(FFLAGS) $< + +FFLAGS += $(PFUNIT_EXTRA_FFLAGS) +FFLAGS += -I../.. + +test_simple_TESTS := test_simple.pf test_simple_fixture.pf +$(eval $(call make_pfunit_test,test_simple)) + +clean: + $(RM) *.o *.mod *.a *.inc + $(RM) test_simple.F90 diff --git a/test/unit/test_simple.pf b/test/unit/test_simple.pf new file mode 100644 index 0000000..eb9e5c8 --- /dev/null +++ b/test/unit/test_simple.pf @@ -0,0 +1,47 @@ +module test_simple + use funit + implicit none + +contains + + !!! Note: no test annotation !!! + subroutine not_a_test() + print*,'this procedure should not be called' + end subroutine not_a_test + + + @test + subroutine test_assert_true_and_false() + @assertTrue(1 == 1) + @assertFalse(1 == 2) + end subroutine test_assert_true_and_false + + + + @test + subroutine test_assert_equal() + integer, parameter :: i_expected = 24 ! 4! + real, parameter :: x_expected = 9. ! 3**2 + + @assertEqual(i_expected, 4*3*2*1) + @assertEqual(x_expected, 3.*3.) + + end subroutine test_assert_equal + + + @test + subroutine test_assert_equal_with_tolerance() + real, parameter :: x_expected = 7. + + ! Absolute tolerance + @assertEqual(x_expected, 7.0, tolerance=0.0) + @assertEqual(x_expected, 7.1, tolerance=0.2) + + ! Relative tolerance + @assertRelativelyEqual(x_expected, 8.0, tolerance=0.5) + + end subroutine test_assert_equal_with_tolerance + + + +end module test_simple diff --git a/test/unit/test_simple_fixture.pf b/test/unit/test_simple_fixture.pf new file mode 100644 index 0000000..12fc891 --- /dev/null +++ b/test/unit/test_simple_fixture.pf @@ -0,0 +1,71 @@ +! Real test fixtures with pFUnit are somewhat involved (see the +! Fixtures directory in this repository). This file demonstrates a +! simple approach to fixtures that uses module variables. + + +! One example where this approach is desirable is when the SUT assumes +! that some file already exists. The test needs to create a file +! before invoking the SUT and then delete it upon completion. But +! what if an assertion fails before the deletion step? Here the +! tear_down() procedure is called _after_ the test and therefore +! guarantees the file is deleted even when tests fail. + + +module test_simple_fixture + use funit + +contains + + ! The following procedure will be called before running + ! each test in the suite. + @before + subroutine set_up() + integer :: unit + open(newunit=unit, file='test.txt', form='formatted', status='new', access='sequential') + write(unit,'(a)') 'A:1' + write(unit,'(a)') 'B:3' + write(unit,'(a)') 'E:7' + close(unit) + + end subroutine set_up + + ! The following procedure will be called after running + ! each test in the suite. + @after + subroutine tear_down() + integer :: unit + logical :: exists + + inquire(file='test.txt', number=unit, exist=exists) + if (unit /= -1) then + close(unit, status='delete') + elseif (exists) then + open(newunit=unit, file='test.txt') + close(unit, status='delete') + end if + + end subroutine tear_down + + @test + subroutine test_1() + integer :: idx + + idx = 1 + + @assertEqual(1, idx) + + end subroutine test_1 + + @test + subroutine test_2() + integer :: idx + + idx = 7 + + @assertEqual(7, idx) + + end subroutine test_2 + + + +end module test_simple_fixture From 054611f68e49cef4e6b37e0c7b95d40d4c95f797 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Tue, 22 Jun 2021 10:49:29 +0100 Subject: [PATCH 09/40] Add readers and writers for regular fortran and MPI IO formats --- makefile | 11 ++++ reader_ftn.f90 | 102 ++++++++++++++++++++++++++++++++++++ reader_mpi.f90 | 50 ++++++++++++++++++ reader_type.f90 | 35 +++++++++++++ writer_ftn.f90 | 115 +++++++++++++++++++++++++++++++++++++++++ writer_mpi.f90 | 134 ++++++++++++++++++++++++++++++++++++++++++++++++ writer_type.f90 | 34 ++++++++++++ 7 files changed, 481 insertions(+) create mode 100644 reader_ftn.f90 create mode 100644 reader_mpi.f90 create mode 100644 reader_type.f90 create mode 100644 writer_ftn.f90 create mode 100644 writer_mpi.f90 create mode 100644 writer_type.f90 diff --git a/makefile b/makefile index 8bb5b4b..f255617 100644 --- a/makefile +++ b/makefile @@ -95,7 +95,12 @@ SRCS := timer.f90 accuracy.f90 diag.f90 dipole.f90 extfield.f90 fields.f90 fwigx pot_abcd.f90 pot_c2h4.f90 pot_c2h6.f90 pot_c3h6.f90 pot_ch3oh.f90 \ pot_xy2.f90 pot_xy3.f90 pot_xy4.f90 pot_zxy2.f90 pot_zxy3.f90 \ prop_xy2.f90 prop_xy2_quad.f90 prop_xy2_spinrot.f90 prop_xy2_spinspin.f90 \ + writer_type.f90 writer_ftn.f90 \ + reader_type.f90 reader_ftn.f90 \ refinement.f90 richmol_data.f90 rotme_cart_tens.f90 symmetry.f90 tran.f90 trove.f90 $(pot_user).f90 +ifdef USE_MPI + SRCS += writer_mpi.f90 reader_mpi.f90 +endif OBJS := ${SRCS:.f90=.o} VPATH = $(SRCDIR):$(user_pot_dir):$(OBJDIR) @@ -212,6 +217,9 @@ prop_xy2.o: prop_xy2.f90 accuracy.o moltype.o timer.o pot_xy2.o prop_xy2_quad.o: prop_xy2_quad.f90 accuracy.o moltype.o timer.o pot_xy2.o prop_xy2_spinrot.o: prop_xy2_spinrot.f90 accuracy.o moltype.o pot_xy2.o timer.o prop_xy2_spinspin.o: prop_xy2_spinspin.f90 accuracy.o moltype.o pot_xy2.o timer.o +reader_type.o: reader_type.f90 +reader_ftn.o: reader_ftn.f90 reader_type.o +reader_mpi.o: reader_mpi.f90 reader_type.o refinement.o: refinement.f90 accuracy.o fields.o timer.o molecules.o moltype.o symmetry.o lapack.o tran.o richmol_data.o: richmol_data.f90 accuracy.o timer.o rotme_cart_tens.o: rotme_cart_tens.f90 accuracy.o timer.o fwigxjpf.o moltype.o accuracy.o @@ -219,3 +227,6 @@ symmetry.o: symmetry.f90 accuracy.o timer.o timer.o: timer.f90 accuracy.o tran.o: tran.f90 accuracy.o timer.o me_numer.o molecules.o fields.o moltype.o symmetry.o perturbation.o mpi_aux.o trove.o: trove.f90 accuracy.o fields.o perturbation.o symmetry.o timer.o moltype.o dipole.o refinement.o tran.o extfield.o +writer_type.o: writer_type.f90 +writer_ftn.o: writer_ftn.f90 writer_type.o +writer_mpi.o: writer_mpi.f90 writer_type.o diff --git a/reader_ftn.f90 b/reader_ftn.f90 new file mode 100644 index 0000000..04fda24 --- /dev/null +++ b/reader_ftn.f90 @@ -0,0 +1,102 @@ +module reader_ftn + use reader_type + + implicit none + + type, extends(readerType) :: readerFTN + contains + procedure :: readScalar => readScalar_FTN + procedure :: read1DArray => read1DArray_FTN + procedure :: read2DArray => read2DArray_FTN + final :: destroy_readerFTN + end type readerFTN + + interface readerFTN + procedure :: new_readerFTN + end interface readerFTN + + private + + public :: readerFTN + + contains + + type(readerFTN) function new_readerFTN(fname, form, access) + ! reader FTN constructor + character (len = *), intent(in) :: fname + character (len = *), intent(in), optional :: form, access + character (len = 20) :: form_val, access_val + + print *, "Creating new readerFTN!" + + if (present(form)) then + form_val = form + else + form_val = 'formatted' + end if + + if (present(access)) then + access_val = access + else + access_val = 'sequential' + end if + + print *, form_val, access_val + + open(newunit=new_readerFTN%iounit, action='read', access=access_val, form=form_val, file=fname) + end function new_readerFTN + + subroutine destroy_readerFTN(this) + type(readerFTN) :: this + print *, "Closing file" + close(this%iounit) + end subroutine + + subroutine readScalar_FTN(this, object) + class(readerFTN) :: this + class(*), intent(out) :: object + print *, "reading object with FTN IO" + select type(object) + type is (integer) + read(this%iounit) object + type is (real) + read(this%iounit) object + type is (complex) + read(this%iounit) object + class default + print *, "Unsupported type!" + end select + end subroutine + + subroutine read1DArray_FTN(this, object) + class(readerFTN) :: this + class(*), dimension(:), intent(out) :: object + print *, "reading 1D array with FTN IO" + select type(object) + type is (integer) + read(this%iounit) object + type is (real) + read(this%iounit) object + type is (complex) + read(this%iounit) object + class default + print *, "Unsupported type!" + end select + end subroutine + + subroutine read2DArray_FTN(this, object) + class(readerFTN) :: this + class(*), dimension(:,:), intent(out) :: object + print *, "reading 2D array with FTN IO" + select type(object) + type is (integer) + read(this%iounit) object + type is (real) + read(this%iounit) object + type is (complex) + read(this%iounit) object + class default + print *, "Unsupported type!" + end select + end subroutine +end module diff --git a/reader_mpi.f90 b/reader_mpi.f90 new file mode 100644 index 0000000..6ddab35 --- /dev/null +++ b/reader_mpi.f90 @@ -0,0 +1,50 @@ +module reader_mpi + use mpi + use reader_type + + implicit none + + type, extends(readerType) :: readerMPI + contains + procedure :: readScalar => readScalar_MPI + procedure :: read1DArray => read1DArray_MPI + procedure :: read2DArray => read2DArray_MPI + end type readerMPI + + private + + public :: readerMPI + + contains + + subroutine readScalar_MPI(this, object) + class(readerMPI) :: this + class(*), intent(out) :: object + print *, "reading object to MPI IO" + ! Example object handling + select type(object) + type is (integer) + print *, object + type is (real) + print *, object + type is (complex) + print *, object + class default + print *, "Unsupported type!" + end select + end subroutine + + subroutine read1DArray_MPI(this, object) + class(readerMPI) :: this + class(*), dimension(:), intent(out) :: object + print *, "reading 1D array to MPI IO" + end subroutine + + subroutine read2DArray_MPI(this, object) + class(readerMPI) :: this + class(*), dimension(:,:), intent(out) :: object + print *, "reading 2D array to MPI IO" + end subroutine + + +end module diff --git a/reader_type.f90 b/reader_type.f90 new file mode 100644 index 0000000..5154d31 --- /dev/null +++ b/reader_type.f90 @@ -0,0 +1,35 @@ +module reader_type + implicit none + + type, abstract :: readerType + integer :: iounit + contains + generic :: read => readScalar, read1DArray, read2DArray + procedure(readScalar), deferred :: readScalar + procedure(read1DArray), deferred :: read1DArray + procedure(read2DArray), deferred :: read2DArray + end type readerType + + abstract interface + subroutine readScalar(this, object) + import readerType + class(readerType) :: this + class(*), intent(out) :: object + end subroutine + subroutine read1DArray(this, object) + import readerType + class(readerType) :: this + class(*), dimension(:), intent(out) :: object + end subroutine + subroutine read2DArray(this, object) + import readerType + class(readerType) :: this + class(*), dimension(:,:), intent(out) :: object + end subroutine + end interface + + private + + public :: readerType + +end module diff --git a/writer_ftn.f90 b/writer_ftn.f90 new file mode 100644 index 0000000..5bfe600 --- /dev/null +++ b/writer_ftn.f90 @@ -0,0 +1,115 @@ +module writer_ftn + use writer_type + + implicit none + + type, extends(writerType) :: writerFTN + integer :: iounit + contains + procedure :: writeScalar => writeScalar_FTN + procedure :: write1DArray => write1DArray_FTN + procedure :: write2DArray => write2DArray_FTN + final :: destroy_writerFTN + end type writerFTN + + interface writerFTN + procedure :: new_writerFTN + end interface writerFTN + + private + + public :: writerFTN + + contains + + type(writerFTN) function new_writerFTN(fname, position, status, form, access) + ! writer FTN constructor + character (len = *), intent(in) :: fname + character (len = *), intent(in), optional :: position, status, form, access + character (len = 20) :: position_val, status_val, form_val, access_val + + print *, "Creating new writerFTN!" + + if (present(position)) then + position_val = position + else + position_val = 'append' + end if + + if (present(status)) then + status_val = status + else + status_val = 'unknown' + end if + + if (present(form)) then + form_val = form + else + form_val = 'formatted' + end if + + if (present(access)) then + access_val = access + else + access_val = 'sequential' + end if + + print *, position_val, status_val, form_val, access_val + + open(newunit=new_writerFTN%iounit, action='write', form=form_val, position=position_val, status=status_val, file=fname) + end function new_writerFTN + + subroutine destroy_writerFTN(this) + type(writerFTN) :: this + print *, "Closing file" + close(this%iounit) + end subroutine + + subroutine writeScalar_FTN(this, object) + class(writerFTN) :: this + class(*), intent(in) :: object + print *, "writing object with FTN IO" + select type(object) + type is (integer) + write(this%iounit) object + type is (real) + write(this%iounit) object + type is (complex) + write(this%iounit) object + class default + print *, "Unsupported type!" + end select + end subroutine + + subroutine write1DArray_FTN(this, object) + class(writerFTN) :: this + class(*), dimension(:), intent(in) :: object + print *, "writing 1D array with FTN IO" + select type(object) + type is (integer) + write(this%iounit) object + type is (real) + write(this%iounit) object + type is (complex) + write(this%iounit) object + class default + print *, "Unsupported type!" + end select + end subroutine + + subroutine write2DArray_FTN(this, object) + class(writerFTN) :: this + class(*), dimension(:,:), intent(in) :: object + print *, "writing 2D array with FTN IO" + select type(object) + type is (integer) + write(this%iounit) object + type is (real) + write(this%iounit) object + type is (complex) + write(this%iounit) object + class default + print *, "Unsupported type!" + end select + end subroutine +end module diff --git a/writer_mpi.f90 b/writer_mpi.f90 new file mode 100644 index 0000000..607b105 --- /dev/null +++ b/writer_mpi.f90 @@ -0,0 +1,134 @@ +module writer_mpi + use mpi + use writer_type + + implicit none + + type, extends(writerType) :: writerMPI + integer (kind=MPI_Offset_kind) :: offset + integer :: fileh, rank + contains + procedure :: writeScalar => writeScalar_MPI + procedure :: write1DArray => write1DArray_MPI + procedure :: write2DArray => write2DArray_MPI + end type writerMPI + + interface writerMPI + procedure :: new_writerMPI + end interface writerMPI + + private + + public :: writerMPI + + contains + + type(writerMPI) function new_writerMPI(fname, position, status, form, access) + ! writer MPI constructor + character (len = *), intent(in) :: fname + character (len = *), intent(in), optional :: position, status, form, access + character (len = 20) :: position_val, status_val, form_val, access_val + integer :: ierr + + print *, "Creating new writerMPI!" + + if (present(position)) then + position_val = position + else + position_val = 'append' + end if + + if (present(status)) then + status_val = status + else + status_val = 'unknown' + end if + + if (present(form)) then + form_val = form + else + form_val = 'formatted' + end if + + if (present(access)) then + access_val = access + else + access_val = 'sequential' + end if + + print *, position_val, status_val, form_val, access_val + + ! FIXME use above flags to change open behaviour + + call MPI_Comm_rank(MPI_COMM_WORLD, new_writerMPI%rank, ierr) + + call MPI_File_open(MPI_COMM_WORLD, fname, MPI_MODE_WRONLY + MPI_MODE_CREATE, MPI_INFO_NULL, new_writerMPI%fileh, ierr) + ! FIXME handle error + end function new_writerMPI + + subroutine destroy_writerMPI(this) + type(writerMPI) :: this + integer :: ierr + print *, "Closing file" + call MPI_File_close(this%fileh, ierr) + ! FIXME handle error + end subroutine + + subroutine writeScalar_MPI(this, object) + class(writerMPI) :: this + class(*), intent(in) :: object + + integer :: byte_size, mpi_type, ierr + + if (this%rank /= 0) then + return + end if + + print *, "writing object to MPI IO" + + select type(object) + type is (integer(kind=4)) + byte_size = 4 + mpi_type = MPI_INTEGER + type is (integer(kind=8)) + byte_size = 8 + mpi_type = MPI_LONG + type is (real(kind=4)) + byte_size = 4 + mpi_type = MPI_FLOAT + type is (real(kind=8)) + byte_size = 8 + mpi_type = MPI_DOUBLE + type is (complex(kind=4)) + byte_size = 8 + mpi_type = MPI_COMPLEX + type is (complex(kind=8)) + byte_size = 16 + mpi_type = MPI_DOUBLE_COMPLEX + class default + print *, "Unsupported type!" + return + end select + + this%offset = this%offset + 4+byte_size+4 + call MPI_File_write(this%fileh, byte_size, 1, MPI_INTEGER, & + MPI_STATUS_IGNORE, ierr) + call MPI_File_write(this%fileh, object, 1, mpi_type, & + MPI_STATUS_IGNORE, ierr) + call MPI_File_write(this%fileh, byte_size, 1, MPI_INTEGER, & + MPI_STATUS_IGNORE, ierr) + end subroutine + + subroutine write1DArray_MPI(this, object) + class(writerMPI) :: this + class(*), dimension(:), intent(in) :: object + print *, "writing 1D array to MPI IO" + end subroutine + + subroutine write2DArray_MPI(this, object) + class(writerMPI) :: this + class(*), dimension(:,:), intent(in) :: object + print *, "writing 2D array to MPI IO" + end subroutine + +end module diff --git a/writer_type.f90 b/writer_type.f90 new file mode 100644 index 0000000..9e0a843 --- /dev/null +++ b/writer_type.f90 @@ -0,0 +1,34 @@ +module writer_type + implicit none + + type, abstract :: writerType + contains + generic :: write => writeScalar, write1DArray, write2DArray + procedure(writeScalar), deferred :: writeScalar + procedure(write1DArray), deferred :: write1DArray + procedure(write2DArray), deferred :: write2DArray + end type writerType + + abstract interface + subroutine writeScalar(this, object) + import writerType + class(writerType) :: this + class(*), intent(in) :: object + end subroutine + subroutine write1DArray(this, object) + import writerType + class(writerType) :: this + class(*), dimension(:), intent(in) :: object + end subroutine + subroutine write2DArray(this, object) + import writerType + class(writerType) :: this + class(*), dimension(:,:), intent(in) :: object + end subroutine + end interface + + private + + public :: writerType + +end module From fc54a58fe39a1de469bcaa72a80af6243e7d869c Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Tue, 22 Jun 2021 19:09:39 +0100 Subject: [PATCH 10/40] Add test for fortran writer --- test/unit/makefile | 15 +++--- test/unit/test_io.pf | 81 ++++++++++++++++++++++++++++++++ test/unit/test_simple.pf | 47 ------------------ test/unit/test_simple_fixture.pf | 71 ---------------------------- writer_ftn.f90 | 11 ++++- 5 files changed, 99 insertions(+), 126 deletions(-) create mode 100644 test/unit/test_io.pf delete mode 100644 test/unit/test_simple.pf delete mode 100644 test/unit/test_simple_fixture.pf diff --git a/test/unit/makefile b/test/unit/makefile index 2610138..1a1c471 100644 --- a/test/unit/makefile +++ b/test/unit/makefile @@ -1,6 +1,8 @@ -include ../../lib/pFUnit/build/PFUNIT.mk +BASE_DIR := ../.. -all: test_simple +include $(BASE_DIR)/lib/pFUnit/build/PFUNIT.mk + +all: test_io %.o : %.F90 $(FC) -c $(FFLAGS) $< @@ -8,9 +10,10 @@ all: test_simple FFLAGS += $(PFUNIT_EXTRA_FFLAGS) FFLAGS += -I../.. -test_simple_TESTS := test_simple.pf test_simple_fixture.pf -$(eval $(call make_pfunit_test,test_simple)) +test_io_TESTS := test_io.pf +test_io_OTHER_SRCS := $(addprefix $(BASE_DIR)/, writer_ftn.f90 writer_type.f90) +$(eval $(call make_pfunit_test,test_io)) clean: - $(RM) *.o *.mod *.a *.inc - $(RM) test_simple.F90 + $(RM) *.o *.mod *.a *.inc + $(RM) test_io.F90 test_io test.dat diff --git a/test/unit/test_io.pf b/test/unit/test_io.pf new file mode 100644 index 0000000..e1582ef --- /dev/null +++ b/test/unit/test_io.pf @@ -0,0 +1,81 @@ +module test_io + use funit + use writer_type + use writer_ftn + + implicit none + + contains + + @test + subroutine test_writing() + type(writerFTN) :: writer + + real, dimension(5) :: array1D + real, dimension(5, 5) :: array2D + real, dimension(5) :: in_array1D + real, dimension(5, 5) :: in_array2D + real :: true_real, in_real + complex :: true_complex, in_complex + integer :: true_integer, in_integer + + integer :: iounit, stat + character(len=*), parameter :: fname = "test.dat" + character(len=*), parameter :: position = "asis" + character(len=*), parameter :: status = "unknown" + character(len=*), parameter :: form = "unformatted" + character(len=*), parameter :: access = "sequential" + + integer i, j + + writer = writerFTN(fname, \ + form=form, access=access, status=status, position=position) + + true_integer = 5 + call writer%write(true_integer) ! int + + true_real = 4.0 + call writer%write(true_real) ! double + + true_complex = (5.0, 1.0) + call writer%write(true_complex) ! complex + + ! Array + array1D = (/2, 3, 4, 5, 6/) + call writer%write(array1D) + + ! 2D array + do i=1,5 + do j=1,5 + array2D(i,j) = i+j + end do + end do + call writer%write(array2D) + + call writer%close_file() + + open(newunit=iounit, iostat=stat, action='read', file=fname, \ + form=form, access=access, status=status, position=position) + + read(iounit) in_integer + read(iounit) in_real + read(iounit) in_complex + read(iounit) in_array1D + read(iounit) in_array2D + + if (stat == 0) close(iounit, status='delete') + + @assertTrue(in_integer == true_integer) + @assertTrue(in_real == true_real) + @assertTrue(in_complex == true_complex) + do i=1,5 + @assertTrue(in_array1D(i) == array1D(i)) + end do + do i=1,5 + do j=1,5 + @assertTrue(in_array2D(i,j) == array2D(i,j)) + end do + end do + end subroutine + +end module test_io diff --git a/test/unit/test_simple.pf b/test/unit/test_simple.pf deleted file mode 100644 index eb9e5c8..0000000 --- a/test/unit/test_simple.pf +++ /dev/null @@ -1,47 +0,0 @@ -module test_simple - use funit - implicit none - -contains - - !!! Note: no test annotation !!! - subroutine not_a_test() - print*,'this procedure should not be called' - end subroutine not_a_test - - - @test - subroutine test_assert_true_and_false() - @assertTrue(1 == 1) - @assertFalse(1 == 2) - end subroutine test_assert_true_and_false - - - - @test - subroutine test_assert_equal() - integer, parameter :: i_expected = 24 ! 4! - real, parameter :: x_expected = 9. ! 3**2 - - @assertEqual(i_expected, 4*3*2*1) - @assertEqual(x_expected, 3.*3.) - - end subroutine test_assert_equal - - - @test - subroutine test_assert_equal_with_tolerance() - real, parameter :: x_expected = 7. - - ! Absolute tolerance - @assertEqual(x_expected, 7.0, tolerance=0.0) - @assertEqual(x_expected, 7.1, tolerance=0.2) - - ! Relative tolerance - @assertRelativelyEqual(x_expected, 8.0, tolerance=0.5) - - end subroutine test_assert_equal_with_tolerance - - - -end module test_simple diff --git a/test/unit/test_simple_fixture.pf b/test/unit/test_simple_fixture.pf deleted file mode 100644 index 12fc891..0000000 --- a/test/unit/test_simple_fixture.pf +++ /dev/null @@ -1,71 +0,0 @@ -! Real test fixtures with pFUnit are somewhat involved (see the -! Fixtures directory in this repository). This file demonstrates a -! simple approach to fixtures that uses module variables. - - -! One example where this approach is desirable is when the SUT assumes -! that some file already exists. The test needs to create a file -! before invoking the SUT and then delete it upon completion. But -! what if an assertion fails before the deletion step? Here the -! tear_down() procedure is called _after_ the test and therefore -! guarantees the file is deleted even when tests fail. - - -module test_simple_fixture - use funit - -contains - - ! The following procedure will be called before running - ! each test in the suite. - @before - subroutine set_up() - integer :: unit - open(newunit=unit, file='test.txt', form='formatted', status='new', access='sequential') - write(unit,'(a)') 'A:1' - write(unit,'(a)') 'B:3' - write(unit,'(a)') 'E:7' - close(unit) - - end subroutine set_up - - ! The following procedure will be called after running - ! each test in the suite. - @after - subroutine tear_down() - integer :: unit - logical :: exists - - inquire(file='test.txt', number=unit, exist=exists) - if (unit /= -1) then - close(unit, status='delete') - elseif (exists) then - open(newunit=unit, file='test.txt') - close(unit, status='delete') - end if - - end subroutine tear_down - - @test - subroutine test_1() - integer :: idx - - idx = 1 - - @assertEqual(1, idx) - - end subroutine test_1 - - @test - subroutine test_2() - integer :: idx - - idx = 7 - - @assertEqual(7, idx) - - end subroutine test_2 - - - -end module test_simple_fixture diff --git a/writer_ftn.f90 b/writer_ftn.f90 index 5bfe600..9a1166a 100644 --- a/writer_ftn.f90 +++ b/writer_ftn.f90 @@ -9,9 +9,11 @@ module writer_ftn procedure :: writeScalar => writeScalar_FTN procedure :: write1DArray => write1DArray_FTN procedure :: write2DArray => write2DArray_FTN + procedure :: close_file final :: destroy_writerFTN end type writerFTN + ! Constructor interface writerFTN procedure :: new_writerFTN end interface writerFTN @@ -33,7 +35,7 @@ type(writerFTN) function new_writerFTN(fname, position, status, form, access) if (present(position)) then position_val = position else - position_val = 'append' + position_val = 'asis' end if if (present(status)) then @@ -45,7 +47,7 @@ type(writerFTN) function new_writerFTN(fname, position, status, form, access) if (present(form)) then form_val = form else - form_val = 'formatted' + form_val = 'unformatted' end if if (present(access)) then @@ -61,6 +63,11 @@ end function new_writerFTN subroutine destroy_writerFTN(this) type(writerFTN) :: this + call this%close_file() + end subroutine + + subroutine close_file(this) + class(writerFTN) :: this print *, "Closing file" close(this%iounit) end subroutine From f156281167f8108c162e1435e292273e7a52dc0b Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Wed, 23 Jun 2021 16:17:32 +0100 Subject: [PATCH 11/40] Run correct unit tests --- makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/makefile b/makefile index f255617..d1c8b03 100644 --- a/makefile +++ b/makefile @@ -161,7 +161,7 @@ regression-tests: $(TARGET) unit-tests: $(TARGET) $(MAKE) -C test/unit echo "Running unit tests" - test/unit/test_simple + test/unit/test_io ################################################################################ ## DEPENDENCIES From 902233d01c6665b09c2f36f3f5f2f384db387669 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Wed, 23 Jun 2021 16:22:10 +0100 Subject: [PATCH 12/40] Cleanup camel case, improve errors and refactor file opening --- test/unit/test_io.pf | 4 +-- writer_ftn.f90 | 81 ++++++++++++++++++++++++-------------------- writer_mpi.f90 | 2 +- 3 files changed, 47 insertions(+), 40 deletions(-) diff --git a/test/unit/test_io.pf b/test/unit/test_io.pf index e1582ef..26396d5 100644 --- a/test/unit/test_io.pf +++ b/test/unit/test_io.pf @@ -28,7 +28,7 @@ module test_io integer i, j - writer = writerFTN(fname, \ + call writer%open(fname, \ form=form, access=access, status=status, position=position) true_integer = 5 @@ -52,7 +52,7 @@ module test_io end do call writer%write(array2D) - call writer%close_file() + call writer%close() open(newunit=iounit, iostat=stat, action='read', file=fname, \ form=form, access=access, status=status, position=position) diff --git a/writer_ftn.f90 b/writer_ftn.f90 index 9a1166a..c2dcf2f 100644 --- a/writer_ftn.f90 +++ b/writer_ftn.f90 @@ -4,75 +4,82 @@ module writer_ftn implicit none type, extends(writerType) :: writerFTN - integer :: iounit + integer :: iounit, stat + logical :: isOpen contains - procedure :: writeScalar => writeScalar_FTN - procedure :: write1DArray => write1DArray_FTN - procedure :: write2DArray => write2DArray_FTN - procedure :: close_file - final :: destroy_writerFTN + procedure :: writeScalar => writeScalarFTN + procedure :: write1DArray => write1DArrayFTN + procedure :: write2DArray => write2DArrayFTN + procedure :: open + procedure :: close + final :: destroyWriterFTN end type writerFTN - ! Constructor - interface writerFTN - procedure :: new_writerFTN - end interface writerFTN - private public :: writerFTN contains - type(writerFTN) function new_writerFTN(fname, position, status, form, access) - ! writer FTN constructor + subroutine open(this, fname, position, status, form, access) + class(writerFTN) :: this character (len = *), intent(in) :: fname character (len = *), intent(in), optional :: position, status, form, access - character (len = 20) :: position_val, status_val, form_val, access_val - - print *, "Creating new writerFTN!" + character (len = 20) :: positionVal, statusVal, formVal, accessVal if (present(position)) then - position_val = position + positionVal = position else - position_val = 'asis' + positionVal = 'asis' end if if (present(status)) then - status_val = status + statusVal = status else - status_val = 'unknown' + statusVal = 'unknown' end if if (present(form)) then - form_val = form + formVal = form else - form_val = 'unformatted' + formVal = 'unformatted' end if if (present(access)) then - access_val = access + accessVal = access else - access_val = 'sequential' + accessVal = 'sequential' end if - print *, position_val, status_val, form_val, access_val + print *, "Opening ", fname, " with ", \ + positionVal, statusVal, formVal, accessVal - open(newunit=new_writerFTN%iounit, action='write', form=form_val, position=position_val, status=status_val, file=fname) - end function new_writerFTN + open(newunit=this%iounit, action='write',\ + form=formVal, position=positionVal, status=statusVal, file=fname,\ + iostat=this%stat) + + if (this%stat == 0) then + this%isOpen = .true. + else + print *, "ERROR: Could not open file. iostat = ", this%stat + endif + end subroutine - subroutine destroy_writerFTN(this) + subroutine destroyWriterFTN(this) type(writerFTN) :: this - call this%close_file() + call this%close() end subroutine - subroutine close_file(this) + subroutine close(this) class(writerFTN) :: this print *, "Closing file" - close(this%iounit) + if (this%isOpen) then + close(this%iounit) + this%isOpen = .false. + endif end subroutine - subroutine writeScalar_FTN(this, object) + subroutine writeScalarFTN(this, object) class(writerFTN) :: this class(*), intent(in) :: object print *, "writing object with FTN IO" @@ -84,11 +91,11 @@ subroutine writeScalar_FTN(this, object) type is (complex) write(this%iounit) object class default - print *, "Unsupported type!" + print *, "ERROR: Tried to write unsupported type" end select end subroutine - subroutine write1DArray_FTN(this, object) + subroutine write1DArrayFTN(this, object) class(writerFTN) :: this class(*), dimension(:), intent(in) :: object print *, "writing 1D array with FTN IO" @@ -100,11 +107,11 @@ subroutine write1DArray_FTN(this, object) type is (complex) write(this%iounit) object class default - print *, "Unsupported type!" + print *, "ERROR: Tried to write unsupported type" end select end subroutine - subroutine write2DArray_FTN(this, object) + subroutine write2DArrayFTN(this, object) class(writerFTN) :: this class(*), dimension(:,:), intent(in) :: object print *, "writing 2D array with FTN IO" @@ -116,7 +123,7 @@ subroutine write2DArray_FTN(this, object) type is (complex) write(this%iounit) object class default - print *, "Unsupported type!" + print *, "ERROR: Tried to write unsupported type" end select end subroutine end module diff --git a/writer_mpi.f90 b/writer_mpi.f90 index 607b105..0dc3db0 100644 --- a/writer_mpi.f90 +++ b/writer_mpi.f90 @@ -106,7 +106,7 @@ subroutine writeScalar_MPI(this, object) byte_size = 16 mpi_type = MPI_DOUBLE_COMPLEX class default - print *, "Unsupported type!" + print *, "ERROR: Tried to write unsupported type" return end select From ea66bf64f376ef874d97a188216ca33db85eb5d9 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Wed, 23 Jun 2021 17:02:40 +0100 Subject: [PATCH 13/40] Add error handling --- errors.f90 | 12 ++++++++++++ errors.fpp | 16 ++++++++++++++++ makefile | 2 +- test/unit/test_io.pf | 7 ++++++- writer_ftn.f90 | 37 ++++++++++++++++++++++++++++++++----- 5 files changed, 67 insertions(+), 7 deletions(-) create mode 100644 errors.f90 create mode 100644 errors.fpp diff --git a/errors.f90 b/errors.f90 new file mode 100644 index 0000000..35bc25a --- /dev/null +++ b/errors.f90 @@ -0,0 +1,12 @@ +module Errors + implicit none + + integer, parameter :: ERR_None = 0, & + ERR_Default = 1, & + ERR_FileNotFound = 2 + + type:: ErrorType + integer :: code + character(len=256) :: message + end type +end module Errors diff --git a/errors.fpp b/errors.fpp new file mode 100644 index 0000000..0eafedb --- /dev/null +++ b/errors.fpp @@ -0,0 +1,16 @@ +! Error.fpp + +! From http://www.luckingtechnotes.com/fortran-error-handling-techniques on 23/06/2021 + +! Macros for error handling. +! Enables user to store errors and exit the subroutine in single statement. +! Fortran preprocessor must be enabled: -fpp. + +! Raise Error +! Store the error code and info (only if the current code is zero). +! Return from the subroutine. +#define RAISE_ERROR(msg, err) if (err%Code == ERR_None) then; err = ErrorType(Code=ERR_Default, Message=msg); end if; return; + +! Pass Error +! Returns if there's an error. +#define HANDLE_ERROR(err) if (err%Code /= ERR_None) then; print *, err%message; return; end if; diff --git a/makefile b/makefile index d1c8b03..2b8c0fb 100644 --- a/makefile +++ b/makefile @@ -228,5 +228,5 @@ timer.o: timer.f90 accuracy.o tran.o: tran.f90 accuracy.o timer.o me_numer.o molecules.o fields.o moltype.o symmetry.o perturbation.o mpi_aux.o trove.o: trove.f90 accuracy.o fields.o perturbation.o symmetry.o timer.o moltype.o dipole.o refinement.o tran.o extfield.o writer_type.o: writer_type.f90 -writer_ftn.o: writer_ftn.f90 writer_type.o +writer_ftn.o: writer_ftn.f90 writer_type.o errors.o writer_mpi.o: writer_mpi.f90 writer_type.o diff --git a/test/unit/test_io.pf b/test/unit/test_io.pf index 26396d5..1ce0ae9 100644 --- a/test/unit/test_io.pf +++ b/test/unit/test_io.pf @@ -1,7 +1,10 @@ +#include "errors.fpp" + module test_io use funit use writer_type use writer_ftn + use errors implicit none @@ -27,9 +30,11 @@ module test_io character(len=*), parameter :: access = "sequential" integer i, j + type(ErrorType) :: err - call writer%open(fname, \ + call writer%open(fname, err, \ form=form, access=access, status=status, position=position) + HANDLE_ERROR(err) true_integer = 5 call writer%write(true_integer) ! int diff --git a/writer_ftn.f90 b/writer_ftn.f90 index c2dcf2f..234ac1c 100644 --- a/writer_ftn.f90 +++ b/writer_ftn.f90 @@ -1,11 +1,15 @@ +#include "errors.fpp" + module writer_ftn use writer_type + use errors implicit none type, extends(writerType) :: writerFTN - integer :: iounit, stat - logical :: isOpen + integer :: iounit = 0 + integer :: stat = 0 + logical :: isOpen = .false. contains procedure :: writeScalar => writeScalarFTN procedure :: write1DArray => write1DArrayFTN @@ -15,18 +19,41 @@ module writer_ftn final :: destroyWriterFTN end type writerFTN + ! Constructor + interface writerFTN + procedure :: newWriterFTN + end interface writerFTN + private public :: writerFTN contains - subroutine open(this, fname, position, status, form, access) + type(writerFTN) function newWriterFTN(fname, err, position, status, form, access) + ! writer FTN constructor + type(ErrorType), intent(inout) :: err + character (len = *), intent(in) :: fname + character (len = *), intent(in), optional :: position, status, form, access + + newWriterFTN%isOpen = .false. + newWriterFTN%stat = 0 + newWriterFTN%iounit = 0 + + call newWriterFTN%open(fname, err, position, status, form, access) + end function + + subroutine open(this, fname, err, position, status, form, access) class(writerFTN) :: this + type(ErrorType), intent(inout) :: err character (len = *), intent(in) :: fname character (len = *), intent(in), optional :: position, status, form, access character (len = 20) :: positionVal, statusVal, formVal, accessVal + if (this%isOpen) then + RAISE_ERROR("ERROR: Tried to open second file", err) + endif + if (present(position)) then positionVal = position else @@ -61,7 +88,7 @@ subroutine open(this, fname, position, status, form, access) if (this%stat == 0) then this%isOpen = .true. else - print *, "ERROR: Could not open file. iostat = ", this%stat + RAISE_ERROR("ERROR: Could not open file", err) endif end subroutine @@ -72,8 +99,8 @@ subroutine destroyWriterFTN(this) subroutine close(this) class(writerFTN) :: this - print *, "Closing file" if (this%isOpen) then + print *, "Closing file" close(this%iounit) this%isOpen = .false. endif From 33e9e43226bb4c3ca0924239405f7b15d34000ea Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Wed, 23 Jun 2021 17:28:32 +0100 Subject: [PATCH 14/40] Rename writer and reader types to writer_base and reader_base --- makefile | 16 ++++++------- reader_type.f90 => reader_base.f90 | 0 test/unit/makefile | 2 +- test/unit/test_io.pf | 2 +- writer_type.f90 => writer_base.f90 | 20 ++++++++-------- writer_ftn.f90 | 14 +++++------ writer_mpi.f90 | 38 +++++++++++++++--------------- 7 files changed, 46 insertions(+), 46 deletions(-) rename reader_type.f90 => reader_base.f90 (100%) rename writer_type.f90 => writer_base.f90 (70%) diff --git a/makefile b/makefile index 2b8c0fb..4d606b6 100644 --- a/makefile +++ b/makefile @@ -95,8 +95,8 @@ SRCS := timer.f90 accuracy.f90 diag.f90 dipole.f90 extfield.f90 fields.f90 fwigx pot_abcd.f90 pot_c2h4.f90 pot_c2h6.f90 pot_c3h6.f90 pot_ch3oh.f90 \ pot_xy2.f90 pot_xy3.f90 pot_xy4.f90 pot_zxy2.f90 pot_zxy3.f90 \ prop_xy2.f90 prop_xy2_quad.f90 prop_xy2_spinrot.f90 prop_xy2_spinspin.f90 \ - writer_type.f90 writer_ftn.f90 \ - reader_type.f90 reader_ftn.f90 \ + writer_base.f90 writer_ftn.f90 \ + reader_base.f90 reader_ftn.f90 \ refinement.f90 richmol_data.f90 rotme_cart_tens.f90 symmetry.f90 tran.f90 trove.f90 $(pot_user).f90 ifdef USE_MPI SRCS += writer_mpi.f90 reader_mpi.f90 @@ -217,9 +217,9 @@ prop_xy2.o: prop_xy2.f90 accuracy.o moltype.o timer.o pot_xy2.o prop_xy2_quad.o: prop_xy2_quad.f90 accuracy.o moltype.o timer.o pot_xy2.o prop_xy2_spinrot.o: prop_xy2_spinrot.f90 accuracy.o moltype.o pot_xy2.o timer.o prop_xy2_spinspin.o: prop_xy2_spinspin.f90 accuracy.o moltype.o pot_xy2.o timer.o -reader_type.o: reader_type.f90 -reader_ftn.o: reader_ftn.f90 reader_type.o -reader_mpi.o: reader_mpi.f90 reader_type.o +reader_base.o: reader_base.f90 +reader_ftn.o: reader_ftn.f90 reader_base.o +reader_mpi.o: reader_mpi.f90 reader_base.o refinement.o: refinement.f90 accuracy.o fields.o timer.o molecules.o moltype.o symmetry.o lapack.o tran.o richmol_data.o: richmol_data.f90 accuracy.o timer.o rotme_cart_tens.o: rotme_cart_tens.f90 accuracy.o timer.o fwigxjpf.o moltype.o accuracy.o @@ -227,6 +227,6 @@ symmetry.o: symmetry.f90 accuracy.o timer.o timer.o: timer.f90 accuracy.o tran.o: tran.f90 accuracy.o timer.o me_numer.o molecules.o fields.o moltype.o symmetry.o perturbation.o mpi_aux.o trove.o: trove.f90 accuracy.o fields.o perturbation.o symmetry.o timer.o moltype.o dipole.o refinement.o tran.o extfield.o -writer_type.o: writer_type.f90 -writer_ftn.o: writer_ftn.f90 writer_type.o errors.o -writer_mpi.o: writer_mpi.f90 writer_type.o +writer_base.o: writer_base.f90 +writer_ftn.o: writer_ftn.f90 writer_base.o errors.o +writer_mpi.o: writer_mpi.f90 writer_base.o diff --git a/reader_type.f90 b/reader_base.f90 similarity index 100% rename from reader_type.f90 rename to reader_base.f90 diff --git a/test/unit/makefile b/test/unit/makefile index 1a1c471..853c510 100644 --- a/test/unit/makefile +++ b/test/unit/makefile @@ -11,7 +11,7 @@ FFLAGS += $(PFUNIT_EXTRA_FFLAGS) FFLAGS += -I../.. test_io_TESTS := test_io.pf -test_io_OTHER_SRCS := $(addprefix $(BASE_DIR)/, writer_ftn.f90 writer_type.f90) +test_io_OTHER_SRCS := $(addprefix $(BASE_DIR)/, writer_ftn.f90 writer_base.f90) $(eval $(call make_pfunit_test,test_io)) clean: diff --git a/test/unit/test_io.pf b/test/unit/test_io.pf index 1ce0ae9..94050ea 100644 --- a/test/unit/test_io.pf +++ b/test/unit/test_io.pf @@ -2,7 +2,7 @@ module test_io use funit - use writer_type + use writer_base use writer_ftn use errors diff --git a/writer_type.f90 b/writer_base.f90 similarity index 70% rename from writer_type.f90 rename to writer_base.f90 index 9e0a843..45abee1 100644 --- a/writer_type.f90 +++ b/writer_base.f90 @@ -1,34 +1,34 @@ -module writer_type +module writer_base implicit none - type, abstract :: writerType + type, abstract :: writerBase contains generic :: write => writeScalar, write1DArray, write2DArray procedure(writeScalar), deferred :: writeScalar procedure(write1DArray), deferred :: write1DArray procedure(write2DArray), deferred :: write2DArray - end type writerType + end type writerBase abstract interface subroutine writeScalar(this, object) - import writerType - class(writerType) :: this + import writerBase + class(writerBase) :: this class(*), intent(in) :: object end subroutine subroutine write1DArray(this, object) - import writerType - class(writerType) :: this + import writerBase + class(writerBase) :: this class(*), dimension(:), intent(in) :: object end subroutine subroutine write2DArray(this, object) - import writerType - class(writerType) :: this + import writerBase + class(writerBase) :: this class(*), dimension(:,:), intent(in) :: object end subroutine end interface private - public :: writerType + public :: writerBase end module diff --git a/writer_ftn.f90 b/writer_ftn.f90 index 234ac1c..944db12 100644 --- a/writer_ftn.f90 +++ b/writer_ftn.f90 @@ -1,12 +1,12 @@ #include "errors.fpp" module writer_ftn - use writer_type + use writer_base use errors implicit none - type, extends(writerType) :: writerFTN + type, extends(writerBase) :: writerFTN integer :: iounit = 0 integer :: stat = 0 logical :: isOpen = .false. @@ -30,17 +30,17 @@ module writer_ftn contains - type(writerFTN) function newWriterFTN(fname, err, position, status, form, access) + type(writerFTN) function newWriterFTN(fname, err, position, status, form, access) result(this) ! writer FTN constructor type(ErrorType), intent(inout) :: err character (len = *), intent(in) :: fname character (len = *), intent(in), optional :: position, status, form, access - newWriterFTN%isOpen = .false. - newWriterFTN%stat = 0 - newWriterFTN%iounit = 0 + this%isOpen = .false. + this%stat = 0 + this%iounit = 0 - call newWriterFTN%open(fname, err, position, status, form, access) + call this%open(fname, err, position, status, form, access) end function subroutine open(this, fname, err, position, status, form, access) diff --git a/writer_mpi.f90 b/writer_mpi.f90 index 0dc3db0..649ac89 100644 --- a/writer_mpi.f90 +++ b/writer_mpi.f90 @@ -1,16 +1,16 @@ module writer_mpi use mpi - use writer_type + use writer_base implicit none - type, extends(writerType) :: writerMPI + type, extends(writerBase) :: writerMPI integer (kind=MPI_Offset_kind) :: offset integer :: fileh, rank contains - procedure :: writeScalar => writeScalar_MPI - procedure :: write1DArray => write1DArray_MPI - procedure :: write2DArray => write2DArray_MPI + procedure :: writeScalar => writeScalarMPI + procedure :: write1DArray => write1DArrayMPI + procedure :: write2DArray => write2DArrayMPI end type writerMPI interface writerMPI @@ -27,36 +27,36 @@ type(writerMPI) function new_writerMPI(fname, position, status, form, access) ! writer MPI constructor character (len = *), intent(in) :: fname character (len = *), intent(in), optional :: position, status, form, access - character (len = 20) :: position_val, status_val, form_val, access_val + character (len = 20) :: positionVal, statusVal, formVal, accessVal integer :: ierr print *, "Creating new writerMPI!" if (present(position)) then - position_val = position + positionVal = position else - position_val = 'append' + positionVal = 'append' end if if (present(status)) then - status_val = status + statusVal = status else - status_val = 'unknown' + statusVal = 'unknown' end if if (present(form)) then - form_val = form + formVal = form else - form_val = 'formatted' + formVal = 'formatted' end if if (present(access)) then - access_val = access + accessVal = access else - access_val = 'sequential' + accessVal = 'sequential' end if - print *, position_val, status_val, form_val, access_val + print *, positionVal, statusVal, formVal, accessVal ! FIXME use above flags to change open behaviour @@ -66,7 +66,7 @@ type(writerMPI) function new_writerMPI(fname, position, status, form, access) ! FIXME handle error end function new_writerMPI - subroutine destroy_writerMPI(this) + subroutine destroyWriterMPI(this) type(writerMPI) :: this integer :: ierr print *, "Closing file" @@ -74,7 +74,7 @@ subroutine destroy_writerMPI(this) ! FIXME handle error end subroutine - subroutine writeScalar_MPI(this, object) + subroutine writeScalarMPI(this, object) class(writerMPI) :: this class(*), intent(in) :: object @@ -119,13 +119,13 @@ subroutine writeScalar_MPI(this, object) MPI_STATUS_IGNORE, ierr) end subroutine - subroutine write1DArray_MPI(this, object) + subroutine write1DArrayMPI(this, object) class(writerMPI) :: this class(*), dimension(:), intent(in) :: object print *, "writing 1D array to MPI IO" end subroutine - subroutine write2DArray_MPI(this, object) + subroutine write2DArrayMPI(this, object) class(writerMPI) :: this class(*), dimension(:,:), intent(in) :: object print *, "writing 2D array to MPI IO" From 69882c5707b5f8b4e61ab725e3c41c86615071fa Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Mon, 28 Jun 2021 16:03:22 +0100 Subject: [PATCH 15/40] Ignoring test outputs --- .gitignore | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/.gitignore b/.gitignore index 2bade0a..517de1a 100644 --- a/.gitignore +++ b/.gitignore @@ -10,6 +10,15 @@ wigxjpf-1.5/lib/ wigxjpf-1.5/bin/ wigxjpf-1.5/mod/ +# test executables +test/unit/test_io + +# regression test files +test/regression/benchmarks +test/regression/benchmarks.tar.gz +test/regression/outputs + + # Windows image file caches Thumbs.db ehthumbs.db From e6aa8101e30184754960ed202afbbe438f41a02f Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Mon, 28 Jun 2021 16:24:00 +0100 Subject: [PATCH 16/40] Add fortran reader tests and cleanup writer --- reader_base.f90 | 21 +++++---- reader_ftn.f90 | 102 ++++++++++++++++++++++++++++++++----------- test/unit/makefile | 2 +- test/unit/test_io.pf | 82 +++++++++++++++++++++++++++++++++- writer_ftn.f90 | 11 +++-- 5 files changed, 174 insertions(+), 44 deletions(-) diff --git a/reader_base.f90 b/reader_base.f90 index 5154d31..9f316f8 100644 --- a/reader_base.f90 +++ b/reader_base.f90 @@ -1,35 +1,34 @@ -module reader_type +module reader_base implicit none - type, abstract :: readerType - integer :: iounit + type, abstract :: readerBase contains generic :: read => readScalar, read1DArray, read2DArray procedure(readScalar), deferred :: readScalar procedure(read1DArray), deferred :: read1DArray procedure(read2DArray), deferred :: read2DArray - end type readerType + end type readerBase abstract interface subroutine readScalar(this, object) - import readerType - class(readerType) :: this + import readerBase + class(readerBase) :: this class(*), intent(out) :: object end subroutine subroutine read1DArray(this, object) - import readerType - class(readerType) :: this + import readerBase + class(readerBase) :: this class(*), dimension(:), intent(out) :: object end subroutine subroutine read2DArray(this, object) - import readerType - class(readerType) :: this + import readerBase + class(readerBase) :: this class(*), dimension(:,:), intent(out) :: object end subroutine end interface private - public :: readerType + public :: readerBase end module diff --git a/reader_ftn.f90 b/reader_ftn.f90 index 04fda24..d1a0ada 100644 --- a/reader_ftn.f90 +++ b/reader_ftn.f90 @@ -1,18 +1,26 @@ +#include "errors.fpp" + module reader_ftn - use reader_type + use reader_base + use errors implicit none - type, extends(readerType) :: readerFTN + type, extends(readerBase) :: readerFTN + integer :: iounit = 0 + integer :: stat = 0 + logical :: isOpen = .false. contains - procedure :: readScalar => readScalar_FTN - procedure :: read1DArray => read1DArray_FTN - procedure :: read2DArray => read2DArray_FTN - final :: destroy_readerFTN + procedure :: readScalar => readScalarFTN + procedure :: read1DArray => read1DArrayFTN + procedure :: read2DArray => read2DArrayFTN + procedure :: open + procedure :: close + final :: destroyReaderFTN end type readerFTN interface readerFTN - procedure :: new_readerFTN + procedure :: newReaderFTN end interface readerFTN private @@ -21,38 +29,82 @@ module reader_ftn contains - type(readerFTN) function new_readerFTN(fname, form, access) + type(readerFTN) function newReaderFTN(fname, err, position, status, form, access) result(this) ! reader FTN constructor + type(ErrorType), intent(inout) :: err + character (len = *), intent(in) :: fname + character (len = *), intent(in), optional :: position, status, form, access + + this%isOpen = .false. + this%stat = 0 + this%iounit = 0 + + call this%open(fname, err, position, status, form, access) + end function + + subroutine destroyReaderFTN(this) + type(readerFTN) :: this + call this%close() + end subroutine + + subroutine open(this, fname, err, position, status, form, access) + class(readerFTN) :: this + type(ErrorType), intent(inout) :: err character (len = *), intent(in) :: fname - character (len = *), intent(in), optional :: form, access - character (len = 20) :: form_val, access_val + character (len = *), intent(in), optional :: position, status, form, access + character (len = 20) :: positionVal, statusVal, formVal, accessVal + + if (this%isOpen) then + RAISE_ERROR("ERROR: Tried to open second file", err) + endif - print *, "Creating new readerFTN!" + if (present(position)) then + positionVal = position + else + positionVal = 'asis' + end if + + if (present(status)) then + statusVal = status + else + statusVal = 'unknown' + end if if (present(form)) then - form_val = form + formVal = form else - form_val = 'formatted' + formVal = 'unformatted' end if if (present(access)) then - access_val = access + accessVal = access else - access_val = 'sequential' + accessVal = 'sequential' end if - print *, form_val, access_val + print *, "Opening ", fname, " with ", \ + positionVal, statusVal, formVal, accessVal - open(newunit=new_readerFTN%iounit, action='read', access=access_val, form=form_val, file=fname) - end function new_readerFTN + open(newunit=this%iounit, action='read',\ + form=formVal, position=positionVal, status=statusVal, file=fname,\ + iostat=this%stat) - subroutine destroy_readerFTN(this) - type(readerFTN) :: this - print *, "Closing file" - close(this%iounit) + if (this%stat == 0) then + this%isOpen = .true. + else + RAISE_ERROR("ERROR: Could not open file", err) + endif + end subroutine + + subroutine close(this) + class(readerFTN) :: this + if (this%isOpen) then + close(this%iounit) + this%isOpen = .false. + endif end subroutine - subroutine readScalar_FTN(this, object) + subroutine readScalarFTN(this, object) class(readerFTN) :: this class(*), intent(out) :: object print *, "reading object with FTN IO" @@ -68,7 +120,7 @@ subroutine readScalar_FTN(this, object) end select end subroutine - subroutine read1DArray_FTN(this, object) + subroutine read1DArrayFTN(this, object) class(readerFTN) :: this class(*), dimension(:), intent(out) :: object print *, "reading 1D array with FTN IO" @@ -84,7 +136,7 @@ subroutine read1DArray_FTN(this, object) end select end subroutine - subroutine read2DArray_FTN(this, object) + subroutine read2DArrayFTN(this, object) class(readerFTN) :: this class(*), dimension(:,:), intent(out) :: object print *, "reading 2D array with FTN IO" diff --git a/test/unit/makefile b/test/unit/makefile index 853c510..b2165bd 100644 --- a/test/unit/makefile +++ b/test/unit/makefile @@ -11,7 +11,7 @@ FFLAGS += $(PFUNIT_EXTRA_FFLAGS) FFLAGS += -I../.. test_io_TESTS := test_io.pf -test_io_OTHER_SRCS := $(addprefix $(BASE_DIR)/, writer_ftn.f90 writer_base.f90) +test_io_OTHER_SRCS := $(addprefix $(BASE_DIR)/, writer_ftn.f90 writer_base.f90 reader_ftn.f90 reader_base.f90) $(eval $(call make_pfunit_test,test_io)) clean: diff --git a/test/unit/test_io.pf b/test/unit/test_io.pf index 94050ea..424b344 100644 --- a/test/unit/test_io.pf +++ b/test/unit/test_io.pf @@ -4,6 +4,8 @@ module test_io use funit use writer_base use writer_ftn + use reader_base + use reader_ftn use errors implicit none @@ -11,7 +13,7 @@ module test_io contains @test - subroutine test_writing() + subroutine test_ftn_writer() type(writerFTN) :: writer real, dimension(5) :: array1D @@ -83,4 +85,82 @@ module test_io end do end subroutine + @test + subroutine test_ftn_reader() + type(readerFTN) :: reader + + real, dimension(5) :: array1D + real, dimension(5, 5) :: array2D + real, dimension(5) :: in_array1D + real, dimension(5, 5) :: in_array2D + real :: true_real, in_real + complex :: true_complex, in_complex + integer :: true_integer, in_integer + + integer :: iounit, stat + character(len=*), parameter :: fname = "test.dat" + character(len=*), parameter :: position = "asis" + character(len=*), parameter :: status = "unknown" + character(len=*), parameter :: form = "unformatted" + character(len=*), parameter :: access = "sequential" + + integer i, j + type(ErrorType) :: err + + open(newunit=iounit, iostat=stat, action='write', file=fname, \ + form=form, access=access, status=status, position=position) + + true_integer = 5 + write(iounit) true_integer ! int + + true_real = 4.0 + write(iounit) true_real ! double + + true_complex = (5.0, 1.0) + write(iounit) true_complex ! complex + + ! Array + array1D = (/2, 3, 4, 5, 6/) + write(iounit) array1D ! 1D array + + ! 2D array + do i=1,5 + do j=1,5 + array2D(i,j) = i+j + end do + end do + write(iounit) array2D ! 2D array + + if (stat == 0) close(iounit) + + call reader%open(fname, err, \ + form=form, access=access, status=status, position=position) + HANDLE_ERROR(err) + + call reader%read(in_integer) + call reader%read(in_real) + call reader%read(in_complex) + call reader%read(in_array1D) + call reader%read(in_array2D) + + call reader%close() + + @assertTrue(in_integer == true_integer) + @assertTrue(in_real == true_real) + @assertTrue(in_complex == true_complex) + do i=1,5 + @assertTrue(in_array1D(i) == array1D(i)) + end do + do i=1,5 + do j=1,5 + @assertTrue(in_array2D(i,j) == array2D(i,j)) + end do + end do + + ! Cleanup test file + open(newunit=iounit, iostat=stat, action='read', file=fname) + if (stat == 0) close(iounit, status='delete') + + end subroutine + end module test_io diff --git a/writer_ftn.f90 b/writer_ftn.f90 index 944db12..0450af5 100644 --- a/writer_ftn.f90 +++ b/writer_ftn.f90 @@ -43,6 +43,11 @@ type(writerFTN) function newWriterFTN(fname, err, position, status, form, access call this%open(fname, err, position, status, form, access) end function + subroutine destroyWriterFTN(this) + type(writerFTN) :: this + call this%close() + end subroutine + subroutine open(this, fname, err, position, status, form, access) class(writerFTN) :: this type(ErrorType), intent(inout) :: err @@ -92,15 +97,9 @@ subroutine open(this, fname, err, position, status, form, access) endif end subroutine - subroutine destroyWriterFTN(this) - type(writerFTN) :: this - call this%close() - end subroutine - subroutine close(this) class(writerFTN) :: this if (this%isOpen) then - print *, "Closing file" close(this%iounit) this%isOpen = .false. endif From dc2371647d74c7dc6b6c28b027f0e04f47ea218e Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Mon, 28 Jun 2021 16:33:34 +0100 Subject: [PATCH 17/40] Fix fortran compiler variable in makefile --- makefile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/makefile b/makefile index 4d606b6..d295c9e 100644 --- a/makefile +++ b/makefile @@ -17,7 +17,7 @@ USE_MPI ?= # Intel ####### ifeq ($(strip $(COMPILER)),intel) - FOR = ifort + FC = ifort FFLAGS = -cpp -ip -align -ansi-alias -mcmodel=medium -parallel -nostandard-realloc-lhs -qopenmp -module $(OBJDIR) ifeq ($(strip $(MODE)),debug) @@ -62,7 +62,7 @@ endif CPPFLAGS = -D_EXTFIELD_DEBUG_ ifdef USE_MPI - FOR = mpif90 + FC = mpif90 FFLAGS += -DTROVE_USE_MPI_ endif From cc3a8be003a1591dd9b5256c0d85c031acd34de0 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Mon, 28 Jun 2021 17:04:43 +0100 Subject: [PATCH 18/40] Add working MPI unit test of MPI writer --- .gitignore | 2 +- makefile | 4 +- reader_mpi.f90 | 16 +++---- test/unit/makefile | 9 +++- test/unit/test_io.pf | 4 +- test/unit/test_mpi_io.pf | 101 +++++++++++++++++++++++++++++++++++++++ writer_mpi.f90 | 57 +++++++++++++++++----- 7 files changed, 167 insertions(+), 26 deletions(-) create mode 100644 test/unit/test_mpi_io.pf diff --git a/.gitignore b/.gitignore index 517de1a..5ec92f5 100644 --- a/.gitignore +++ b/.gitignore @@ -12,13 +12,13 @@ wigxjpf-1.5/mod/ # test executables test/unit/test_io +test/unit/test_mpi_io # regression test files test/regression/benchmarks test/regression/benchmarks.tar.gz test/regression/outputs - # Windows image file caches Thumbs.db ehthumbs.db diff --git a/makefile b/makefile index d295c9e..0245302 100644 --- a/makefile +++ b/makefile @@ -67,6 +67,7 @@ ifdef USE_MPI endif export FC +export USE_MPI ################################################################################ ## LIBRARIES @@ -159,9 +160,10 @@ regression-tests: $(TARGET) cd test/regression; ./run_regression_tests.sh unit-tests: $(TARGET) - $(MAKE) -C test/unit + $(MAKE) -C test/unit test_io test_mpi_io echo "Running unit tests" test/unit/test_io + mpirun -n 4 --mca opal_warn_on_missing_libcuda 0 test/unit/test_mpi_io ################################################################################ ## DEPENDENCIES diff --git a/reader_mpi.f90 b/reader_mpi.f90 index 6ddab35..b718a6c 100644 --- a/reader_mpi.f90 +++ b/reader_mpi.f90 @@ -1,14 +1,14 @@ module reader_mpi use mpi - use reader_type + use reader_base implicit none - type, extends(readerType) :: readerMPI + type, extends(readerBase) :: readerMPI contains - procedure :: readScalar => readScalar_MPI - procedure :: read1DArray => read1DArray_MPI - procedure :: read2DArray => read2DArray_MPI + procedure :: readScalar => readScalarMPI + procedure :: read1DArray => read1DArrayMPI + procedure :: read2DArray => read2DArrayMPI end type readerMPI private @@ -17,7 +17,7 @@ module reader_mpi contains - subroutine readScalar_MPI(this, object) + subroutine readScalarMPI(this, object) class(readerMPI) :: this class(*), intent(out) :: object print *, "reading object to MPI IO" @@ -34,13 +34,13 @@ subroutine readScalar_MPI(this, object) end select end subroutine - subroutine read1DArray_MPI(this, object) + subroutine read1DArrayMPI(this, object) class(readerMPI) :: this class(*), dimension(:), intent(out) :: object print *, "reading 1D array to MPI IO" end subroutine - subroutine read2DArray_MPI(this, object) + subroutine read2DArrayMPI(this, object) class(readerMPI) :: this class(*), dimension(:,:), intent(out) :: object print *, "reading 2D array to MPI IO" diff --git a/test/unit/makefile b/test/unit/makefile index b2165bd..7c82af6 100644 --- a/test/unit/makefile +++ b/test/unit/makefile @@ -2,8 +2,6 @@ BASE_DIR := ../.. include $(BASE_DIR)/lib/pFUnit/build/PFUNIT.mk -all: test_io - %.o : %.F90 $(FC) -c $(FFLAGS) $< @@ -14,6 +12,13 @@ test_io_TESTS := test_io.pf test_io_OTHER_SRCS := $(addprefix $(BASE_DIR)/, writer_ftn.f90 writer_base.f90 reader_ftn.f90 reader_base.f90) $(eval $(call make_pfunit_test,test_io)) +ifdef USE_MPI +FFLAGS += -DTROVE_USE_MPI_ +test_mpi_io_TESTS := test_mpi_io.pf +test_mpi_io_OTHER_SRCS := $(addprefix $(BASE_DIR)/, writer_mpi.f90 writer_base.f90 reader_mpi.f90 reader_base.f90) +$(eval $(call make_pfunit_test,test_mpi_io)) +endif + clean: $(RM) *.o *.mod *.a *.inc $(RM) test_io.F90 test_io test.dat diff --git a/test/unit/test_io.pf b/test/unit/test_io.pf index 424b344..4a83f34 100644 --- a/test/unit/test_io.pf +++ b/test/unit/test_io.pf @@ -13,7 +13,7 @@ module test_io contains @test - subroutine test_ftn_writer() + subroutine testFTNWriter() type(writerFTN) :: writer real, dimension(5) :: array1D @@ -86,7 +86,7 @@ module test_io end subroutine @test - subroutine test_ftn_reader() + subroutine testFTNReader() type(readerFTN) :: reader real, dimension(5) :: array1D diff --git a/test/unit/test_mpi_io.pf b/test/unit/test_mpi_io.pf new file mode 100644 index 0000000..3245077 --- /dev/null +++ b/test/unit/test_mpi_io.pf @@ -0,0 +1,101 @@ +#include "errors.fpp" + +module test_mpi_io + use funit + use mpi + use writer_base + use writer_mpi + use reader_base + use reader_mpi + use errors + + implicit none + + contains + + @test + subroutine testMPIWriter() + + type(writerMPI) :: writer + + real, dimension(5) :: array1D + real, dimension(5, 5) :: array2D + real, dimension(5) :: in_array1D + real, dimension(5, 5) :: in_array2D + real :: true_real, in_real + complex :: true_complex, in_complex + integer :: true_integer, in_integer + + integer :: iounit, stat + character(len=*), parameter :: fname = "test.dat" + character(len=*), parameter :: position = "asis" + character(len=*), parameter :: status = "unknown" + character(len=*), parameter :: form = "unformatted" + character(len=*), parameter :: access = "sequential" + + integer i, j + type(ErrorType) :: err + + integer :: ierr, comsize, rank + + call MPI_Init(ierr) + call MPI_Comm_size(MPI_COMM_WORLD, comsize, ierr) + call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr) + + call writer%open(fname, err, \ + form=form, access=access, status=status, position=position) + HANDLE_ERROR(err) + + true_integer = 5 + call writer%write(true_integer) ! int + + true_real = 4.0 + call writer%write(true_real) ! double + + true_complex = (5.0, 1.0) + call writer%write(true_complex) ! complex + + ! Array + array1D = (/2, 3, 4, 5, 6/) + /*call writer%write(array1D)*/ + + ! 2D array + do i=1,5 + do j=1,5 + array2D(i,j) = i+j + end do + end do + /*call writer%write(array2D)*/ + + call writer%close() + + open(newunit=iounit, iostat=stat, action='read', file=fname, \ + form=form, access=access, status=status, position=position) + + ! Only run test on main process + if(rank == 0) then + read(iounit) in_integer + read(iounit) in_real + read(iounit) in_complex + /*read(iounit) in_array1D*/ + /*read(iounit) in_array2D*/ + + if (stat == 0) close(iounit, status='delete') + + @assertTrue(in_integer == true_integer) + @assertTrue(in_real == true_real) + @assertTrue(in_complex == true_complex) + /*do i=1,5*/ + /*@assertTrue(in_array1D(i) == array1D(i))*/ + /*end do*/ + /*do i=1,5*/ + /*do j=1,5*/ + /*@assertTrue(in_array2D(i,j) == array2D(i,j))*/ + /*end do*/ + /*end do*/ + endif + + call MPI_Finalize(ierr) + + end subroutine testMPIWriter +end module diff --git a/writer_mpi.f90 b/writer_mpi.f90 index 649ac89..ee68a53 100644 --- a/writer_mpi.f90 +++ b/writer_mpi.f90 @@ -1,20 +1,27 @@ +#include "errors.fpp" + module writer_mpi use mpi use writer_base + use errors implicit none type, extends(writerBase) :: writerMPI integer (kind=MPI_Offset_kind) :: offset integer :: fileh, rank + logical :: isOpen = .false. contains procedure :: writeScalar => writeScalarMPI procedure :: write1DArray => write1DArrayMPI procedure :: write2DArray => write2DArrayMPI + procedure :: open + procedure :: close + final :: destroyWriterMPI end type writerMPI interface writerMPI - procedure :: new_writerMPI + procedure :: newWriterMPI end interface writerMPI private @@ -23,14 +30,37 @@ module writer_mpi contains - type(writerMPI) function new_writerMPI(fname, position, status, form, access) + type(writerMPI) function newWriterMPI(fname, err, position, status, form, access) result(this) + ! writer MPI constructor + type(ErrorType), intent(inout) :: err + character (len = *), intent(in) :: fname + character (len = *), intent(in), optional :: position, status, form, access + + this%isOpen = .false. + this%offset = 0 + this%fileh = 0 + this%rank = 0 + + call this%open(fname, err, position, status, form, access) + end function + + subroutine destroyWriterMPI(this) + type(writerMPI) :: this + call this%close() + end subroutine + + subroutine open(this, fname, err, position, status, form, access) ! writer MPI constructor + class(writerMPI) :: this + type(ErrorType), intent(inout) :: err character (len = *), intent(in) :: fname character (len = *), intent(in), optional :: position, status, form, access character (len = 20) :: positionVal, statusVal, formVal, accessVal integer :: ierr - print *, "Creating new writerMPI!" + if (this%isOpen) then + RAISE_ERROR("ERROR: Tried to open second file", err) + endif if (present(position)) then positionVal = position @@ -56,23 +86,26 @@ type(writerMPI) function new_writerMPI(fname, position, status, form, access) accessVal = 'sequential' end if - print *, positionVal, statusVal, formVal, accessVal + print *, "MPI: Opening ", fname, " with ", \ + positionVal, statusVal, formVal, accessVal ! FIXME use above flags to change open behaviour - call MPI_Comm_rank(MPI_COMM_WORLD, new_writerMPI%rank, ierr) + call MPI_Comm_rank(MPI_COMM_WORLD, this%rank, ierr) - call MPI_File_open(MPI_COMM_WORLD, fname, MPI_MODE_WRONLY + MPI_MODE_CREATE, MPI_INFO_NULL, new_writerMPI%fileh, ierr) + call MPI_File_open(MPI_COMM_WORLD, fname, MPI_MODE_WRONLY + MPI_MODE_CREATE, MPI_INFO_NULL, this%fileh, ierr) ! FIXME handle error - end function new_writerMPI + end subroutine open - subroutine destroyWriterMPI(this) - type(writerMPI) :: this + subroutine close(this) + class(writerMPI) :: this integer :: ierr - print *, "Closing file" - call MPI_File_close(this%fileh, ierr) + if (this%isOpen) then + call MPI_File_close(this%fileh, ierr) + this%isOpen = .false. + endif ! FIXME handle error - end subroutine + end subroutine close subroutine writeScalarMPI(this, object) class(writerMPI) :: this From a8e90c73dfe49b716d4df8344ba5a2f93aa47072 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Mon, 28 Jun 2021 17:31:56 +0100 Subject: [PATCH 19/40] Refactor byte size and MPI type determination into function --- writer_mpi.f90 | 60 +++++++++++++++++++++++++++----------------------- 1 file changed, 32 insertions(+), 28 deletions(-) diff --git a/writer_mpi.f90 b/writer_mpi.f90 index ee68a53..8ce61f0 100644 --- a/writer_mpi.f90 +++ b/writer_mpi.f90 @@ -107,48 +107,52 @@ subroutine close(this) ! FIXME handle error end subroutine close - subroutine writeScalarMPI(this, object) - class(writerMPI) :: this + subroutine getMPIVarInfo(object, byteSize, mpiType) class(*), intent(in) :: object - - integer :: byte_size, mpi_type, ierr - - if (this%rank /= 0) then - return - end if - - print *, "writing object to MPI IO" + integer, intent(out) :: byteSize, mpiType select type(object) type is (integer(kind=4)) - byte_size = 4 - mpi_type = MPI_INTEGER + byteSize = 4 + mpiType = MPI_INTEGER type is (integer(kind=8)) - byte_size = 8 - mpi_type = MPI_LONG + byteSize = 8 + mpiType = MPI_LONG type is (real(kind=4)) - byte_size = 4 - mpi_type = MPI_FLOAT + byteSize = 4 + mpiType = MPI_FLOAT type is (real(kind=8)) - byte_size = 8 - mpi_type = MPI_DOUBLE + byteSize = 8 + mpiType = MPI_DOUBLE type is (complex(kind=4)) - byte_size = 8 - mpi_type = MPI_COMPLEX + byteSize = 8 + mpiType = MPI_COMPLEX type is (complex(kind=8)) - byte_size = 16 - mpi_type = MPI_DOUBLE_COMPLEX + byteSize = 16 + mpiType = MPI_DOUBLE_COMPLEX class default - print *, "ERROR: Tried to write unsupported type" - return + print *, "ERROR: Unknown type" end select + end subroutine + + subroutine writeScalarMPI(this, object) + class(writerMPI) :: this + class(*), intent(in) :: object + + integer :: byteSize, mpiType, ierr + + if (this%rank /= 0) then + return + end if + + call getMPIVarInfo(object, byteSize, mpiType) - this%offset = this%offset + 4+byte_size+4 - call MPI_File_write(this%fileh, byte_size, 1, MPI_INTEGER, & + this%offset = this%offset + 4+byteSize+4 + call MPI_File_write(this%fileh, byteSize, 1, MPI_INTEGER, & MPI_STATUS_IGNORE, ierr) - call MPI_File_write(this%fileh, object, 1, mpi_type, & + call MPI_File_write(this%fileh, object, 1, mpiType, & MPI_STATUS_IGNORE, ierr) - call MPI_File_write(this%fileh, byte_size, 1, MPI_INTEGER, & + call MPI_File_write(this%fileh, byteSize, 1, MPI_INTEGER, & MPI_STATUS_IGNORE, ierr) end subroutine From 4418d13efae60162d6fdb0bf2212887378e9a2e3 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Tue, 29 Jun 2021 13:33:16 +0100 Subject: [PATCH 20/40] Use TROVE's MPI initialisation routines in MPI unit tests (this will also set up blacs) --- test/unit/makefile | 8 +++++++- test/unit/test_mpi_io.pf | 11 ++++++----- 2 files changed, 13 insertions(+), 6 deletions(-) diff --git a/test/unit/makefile b/test/unit/makefile index 7c82af6..a0c745f 100644 --- a/test/unit/makefile +++ b/test/unit/makefile @@ -8,6 +8,11 @@ include $(BASE_DIR)/lib/pFUnit/build/PFUNIT.mk FFLAGS += $(PFUNIT_EXTRA_FFLAGS) FFLAGS += -I../.. +LAPACK = -L${MKLROOT}/lib/intel64 -Wl,--no-as-needed -lmkl_gf_lp64 -lmkl_gnu_thread -lmkl_core -lgomp -lpthread -lm -ldl +ifdef USE_MPI +LAPACK += -lmkl_blacs_openmpi_lp64 -lmkl_scalapack_lp64 +endif + test_io_TESTS := test_io.pf test_io_OTHER_SRCS := $(addprefix $(BASE_DIR)/, writer_ftn.f90 writer_base.f90 reader_ftn.f90 reader_base.f90) $(eval $(call make_pfunit_test,test_io)) @@ -15,7 +20,8 @@ $(eval $(call make_pfunit_test,test_io)) ifdef USE_MPI FFLAGS += -DTROVE_USE_MPI_ test_mpi_io_TESTS := test_mpi_io.pf -test_mpi_io_OTHER_SRCS := $(addprefix $(BASE_DIR)/, writer_mpi.f90 writer_base.f90 reader_mpi.f90 reader_base.f90) +test_mpi_io_OTHER_LIBRARIES := ${LAPACK} +test_mpi_io_OTHER_SRCS := $(addprefix $(BASE_DIR)/, writer_mpi.f90 writer_base.f90 reader_mpi.f90 reader_base.f90 mpi_aux.f90 timer.f90 accuracy.f90) $(eval $(call make_pfunit_test,test_mpi_io)) endif diff --git a/test/unit/test_mpi_io.pf b/test/unit/test_mpi_io.pf index 3245077..a21f496 100644 --- a/test/unit/test_mpi_io.pf +++ b/test/unit/test_mpi_io.pf @@ -2,7 +2,8 @@ module test_mpi_io use funit - use mpi + use mpi_f08 + use mpi_aux use writer_base use writer_mpi use reader_base @@ -36,10 +37,10 @@ module test_mpi_io integer i, j type(ErrorType) :: err - integer :: ierr, comsize, rank + integer :: ierr, rank, allocinfo + + call co_init_comms() - call MPI_Init(ierr) - call MPI_Comm_size(MPI_COMM_WORLD, comsize, ierr) call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr) call writer%open(fname, err, \ @@ -95,7 +96,7 @@ module test_mpi_io /*end do*/ endif - call MPI_Finalize(ierr) + call co_finalize_comms() end subroutine testMPIWriter end module From ec2a698ff19bedd9823174f15214580df6526a75 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Wed, 30 Jun 2021 14:51:24 +0100 Subject: [PATCH 21/40] Add default data to error type --- errors.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/errors.f90 b/errors.f90 index 35bc25a..27389e0 100644 --- a/errors.f90 +++ b/errors.f90 @@ -6,7 +6,7 @@ module Errors ERR_FileNotFound = 2 type:: ErrorType - integer :: code - character(len=256) :: message + integer :: code = ERR_None + character(len=256) :: message = "" end type end module Errors From f489aead8f2d9fdff04f3f818f362ad2125f98a5 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Wed, 30 Jun 2021 14:51:41 +0100 Subject: [PATCH 22/40] Fix makefile dependencies --- makefile | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/makefile b/makefile index 0245302..4a4672a 100644 --- a/makefile +++ b/makefile @@ -219,9 +219,9 @@ prop_xy2.o: prop_xy2.f90 accuracy.o moltype.o timer.o pot_xy2.o prop_xy2_quad.o: prop_xy2_quad.f90 accuracy.o moltype.o timer.o pot_xy2.o prop_xy2_spinrot.o: prop_xy2_spinrot.f90 accuracy.o moltype.o pot_xy2.o timer.o prop_xy2_spinspin.o: prop_xy2_spinspin.f90 accuracy.o moltype.o pot_xy2.o timer.o -reader_base.o: reader_base.f90 -reader_ftn.o: reader_ftn.f90 reader_base.o -reader_mpi.o: reader_mpi.f90 reader_base.o +reader_base.o: reader_base.f90 mpi_aux.o +reader_ftn.o: reader_ftn.f90 reader_base.o mpi_aux.o +reader_mpi.o: reader_mpi.f90 reader_base.o mpi_aux.o refinement.o: refinement.f90 accuracy.o fields.o timer.o molecules.o moltype.o symmetry.o lapack.o tran.o richmol_data.o: richmol_data.f90 accuracy.o timer.o rotme_cart_tens.o: rotme_cart_tens.f90 accuracy.o timer.o fwigxjpf.o moltype.o accuracy.o @@ -229,6 +229,6 @@ symmetry.o: symmetry.f90 accuracy.o timer.o timer.o: timer.f90 accuracy.o tran.o: tran.f90 accuracy.o timer.o me_numer.o molecules.o fields.o moltype.o symmetry.o perturbation.o mpi_aux.o trove.o: trove.f90 accuracy.o fields.o perturbation.o symmetry.o timer.o moltype.o dipole.o refinement.o tran.o extfield.o -writer_base.o: writer_base.f90 -writer_ftn.o: writer_ftn.f90 writer_base.o errors.o -writer_mpi.o: writer_mpi.f90 writer_base.o +writer_base.o: writer_base.f90 mpi_aux.o +writer_ftn.o: writer_ftn.f90 writer_base.o errors.o mpi_aux.o +writer_mpi.o: writer_mpi.f90 writer_base.o mpi_aux.o From bb473b6f60505895887db2913e17778e034b1a6f Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Wed, 30 Jun 2021 14:52:20 +0100 Subject: [PATCH 23/40] Ensure make clean removes mpi io test outputs --- test/unit/makefile | 1 + 1 file changed, 1 insertion(+) diff --git a/test/unit/makefile b/test/unit/makefile index a0c745f..ebaa16f 100644 --- a/test/unit/makefile +++ b/test/unit/makefile @@ -28,3 +28,4 @@ endif clean: $(RM) *.o *.mod *.a *.inc $(RM) test_io.F90 test_io test.dat + $(RM) test_mpi_io.F90 test_mpi_io test.dat From 838508df84a1198d391abf7aef25e70f5cd2ec1c Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Wed, 30 Jun 2021 14:53:57 +0100 Subject: [PATCH 24/40] Implement outputting of 2D arrays using MPI IO while imitating fortran's record format --- test/unit/test_mpi_io.pf | 85 ++++++++++++++++++++++++++++------------ writer_base.f90 | 13 +++++- writer_ftn.f90 | 10 +++++ writer_mpi.f90 | 76 +++++++++++++++++++++++++++-------- 4 files changed, 140 insertions(+), 44 deletions(-) diff --git a/test/unit/test_mpi_io.pf b/test/unit/test_mpi_io.pf index a21f496..3196801 100644 --- a/test/unit/test_mpi_io.pf +++ b/test/unit/test_mpi_io.pf @@ -9,9 +9,12 @@ module test_mpi_io use reader_base use reader_mpi use errors + use accuracy implicit none + integer,external :: INDXL2G + contains @test @@ -19,10 +22,13 @@ module test_mpi_io type(writerMPI) :: writer - real, dimension(5) :: array1D - real, dimension(5, 5) :: array2D - real, dimension(5) :: in_array1D - real, dimension(5, 5) :: in_array2D + integer, parameter :: array2DNRow = 4 + integer, parameter :: array2DNCol = 3 + real(rk), allocatable :: array2D(:,:) + real(rk) :: in_array2D(array2DNRow,array2DNCol) + integer :: array2D_descr(9) = 0 + type(MPI_Datatype) :: array2D_block_type + real :: true_real, in_real complex :: true_complex, in_complex integer :: true_integer, in_integer @@ -35,18 +41,21 @@ module test_mpi_io character(len=*), parameter :: access = "sequential" integer i, j + integer :: gi = 0, gj = 0, MB, NB, RSRC, CSRC type(ErrorType) :: err - integer :: ierr, rank, allocinfo + integer :: ierr, rank, allocinfo = 0 call co_init_comms() call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr) + if(ierr.ne.0) print *, "Error: could not get rank" call writer%open(fname, err, \ form=form, access=access, status=status, position=position) HANDLE_ERROR(err) + ! Test writing scalars true_integer = 5 call writer%write(true_integer) ! int @@ -56,17 +65,32 @@ module test_mpi_io true_complex = (5.0, 1.0) call writer%write(true_complex) ! complex - ! Array - array1D = (/2, 3, 4, 5, 6/) - /*call writer%write(array1D)*/ + ! Test writing an array + call co_block_type_init(array2D, array2DNCol, array2DNRow, array2D_descr, allocinfo, array2D_block_type) + if(allocinfo.ne.0) print *, "ERROR: couldn't allocate array" + + MB = array2D_descr(5) + NB = array2D_descr(6) - ! 2D array - do i=1,5 - do j=1,5 - array2D(i,j) = i+j + RSRC = array2D_descr(7) + CSRC = array2D_descr(8) + + do i=1,size(array2D,1) + do j=1,size(array2D,2) + gi = INDXL2G (i, MB, myprow, RSRC, nprow) + gj = INDXL2G (j, NB, mypcol, CSRC, npcol) + array2D(i,j) = array2DNCol*(gi-1) + (gj) end do end do - /*call writer%write(array2D)*/ + + call writer%write(array2D, array2D_descr, array2D_block_type) + + ! Test writing something after array + true_integer = 5 + call writer%write(true_integer) ! int + + ! Test writing another array + call writer%write(array2D, array2D_descr, array2D_block_type) call writer%close() @@ -76,24 +100,33 @@ module test_mpi_io ! Only run test on main process if(rank == 0) then read(iounit) in_integer + @assertTrue(in_integer == true_integer) + read(iounit) in_real + @assertTrue(in_real == true_real) + read(iounit) in_complex - /*read(iounit) in_array1D*/ - /*read(iounit) in_array2D*/ + @assertTrue(in_complex == true_complex) - if (stat == 0) close(iounit, status='delete') + read(iounit) in_array2D + do i=1,array2DNRow + do j=1,array2DNCol + @assertTrue(in_array2D(i,j) == array2DNCol*(i-1) + j) + end do + end do + read(iounit) in_integer @assertTrue(in_integer == true_integer) - @assertTrue(in_real == true_real) - @assertTrue(in_complex == true_complex) - /*do i=1,5*/ - /*@assertTrue(in_array1D(i) == array1D(i))*/ - /*end do*/ - /*do i=1,5*/ - /*do j=1,5*/ - /*@assertTrue(in_array2D(i,j) == array2D(i,j))*/ - /*end do*/ - /*end do*/ + + read(iounit) in_array2D + do i=1,array2DNRow + do j=1,array2DNCol + @assertTrue(in_array2D(i,j) == array2DNCol*(i-1) + j) + end do + end do + + if (stat == 0) close(iounit, status='delete') + endif call co_finalize_comms() diff --git a/writer_base.f90 b/writer_base.f90 index 45abee1..1502507 100644 --- a/writer_base.f90 +++ b/writer_base.f90 @@ -1,12 +1,15 @@ module writer_base + use mpi_aux + implicit none type, abstract :: writerBase contains - generic :: write => writeScalar, write1DArray, write2DArray + generic :: write => writeScalar, write1DArray, write2DArray, write2DArrayDist procedure(writeScalar), deferred :: writeScalar procedure(write1DArray), deferred :: write1DArray procedure(write2DArray), deferred :: write2DArray + procedure(write2DArrayDist), deferred :: write2DArrayDist end type writerBase abstract interface @@ -25,6 +28,14 @@ subroutine write2DArray(this, object) class(writerBase) :: this class(*), dimension(:,:), intent(in) :: object end subroutine + subroutine write2DArrayDist(this, object, descr, block_type) + import writerBase + import MPI_Datatype + class(writerBase) :: this + class(*), dimension(:,:), intent(in) :: object + integer, dimension(9), intent(in) :: descr + type(MPI_Datatype), intent(in) :: block_type + end subroutine end interface private diff --git a/writer_ftn.f90 b/writer_ftn.f90 index 0450af5..1035f70 100644 --- a/writer_ftn.f90 +++ b/writer_ftn.f90 @@ -1,6 +1,7 @@ #include "errors.fpp" module writer_ftn + use mpi_aux use writer_base use errors @@ -14,6 +15,7 @@ module writer_ftn procedure :: writeScalar => writeScalarFTN procedure :: write1DArray => write1DArrayFTN procedure :: write2DArray => write2DArrayFTN + procedure :: write2DArrayDist => write2DArrayFTNDist procedure :: open procedure :: close final :: destroyWriterFTN @@ -152,4 +154,12 @@ subroutine write2DArrayFTN(this, object) print *, "ERROR: Tried to write unsupported type" end select end subroutine + + subroutine write2DArrayFTNDist(this, object, descr, block_type) + class(writerFTN) :: this + class(*), dimension(:,:), intent(in) :: object + integer, intent(in) :: descr(9) + type(MPI_Datatype), intent(in) :: block_type + print *, "ERROR: tried to write distributed array using fortran writer. Use MPI writer instead." + end subroutine end module diff --git a/writer_mpi.f90 b/writer_mpi.f90 index 8ce61f0..7a59c58 100644 --- a/writer_mpi.f90 +++ b/writer_mpi.f90 @@ -1,20 +1,23 @@ #include "errors.fpp" module writer_mpi - use mpi + use mpi_f08 + use mpi_aux use writer_base use errors implicit none type, extends(writerBase) :: writerMPI - integer (kind=MPI_Offset_kind) :: offset - integer :: fileh, rank + integer (kind=MPI_Offset_kind) :: offset = 0 + integer :: rank = 0 + type(MPI_File) :: fileh logical :: isOpen = .false. contains procedure :: writeScalar => writeScalarMPI procedure :: write1DArray => write1DArrayMPI procedure :: write2DArray => write2DArrayMPI + procedure :: write2DArrayDist => write2DArrayMPIDist procedure :: open procedure :: close final :: destroyWriterMPI @@ -36,11 +39,6 @@ type(writerMPI) function newWriterMPI(fname, err, position, status, form, access character (len = *), intent(in) :: fname character (len = *), intent(in), optional :: position, status, form, access - this%isOpen = .false. - this%offset = 0 - this%fileh = 0 - this%rank = 0 - call this%open(fname, err, position, status, form, access) end function @@ -109,7 +107,8 @@ end subroutine close subroutine getMPIVarInfo(object, byteSize, mpiType) class(*), intent(in) :: object - integer, intent(out) :: byteSize, mpiType + integer, intent(out) :: byteSize + type(MPI_Datatype), intent(out) :: mpiType select type(object) type is (integer(kind=4)) @@ -139,15 +138,16 @@ subroutine writeScalarMPI(this, object) class(writerMPI) :: this class(*), intent(in) :: object - integer :: byteSize, mpiType, ierr + integer :: byteSize, ierr + type(MPI_Datatype) :: mpiType + + call getMPIVarInfo(object, byteSize, mpiType) + this%offset = this%offset + 4+byteSize+4 if (this%rank /= 0) then return end if - call getMPIVarInfo(object, byteSize, mpiType) - - this%offset = this%offset + 4+byteSize+4 call MPI_File_write(this%fileh, byteSize, 1, MPI_INTEGER, & MPI_STATUS_IGNORE, ierr) call MPI_File_write(this%fileh, object, 1, mpiType, & @@ -158,14 +158,56 @@ subroutine writeScalarMPI(this, object) subroutine write1DArrayMPI(this, object) class(writerMPI) :: this - class(*), dimension(:), intent(in) :: object - print *, "writing 1D array to MPI IO" + class(*), intent(in) :: object(:) + print *, "ERROR: 1D array saving not currently supported" end subroutine subroutine write2DArrayMPI(this, object) class(writerMPI) :: this - class(*), dimension(:,:), intent(in) :: object - print *, "writing 2D array to MPI IO" + class(*), intent(in) :: object(:,:) + print *, "ERROR: Writing non-distributed array using MPI writer not supported." + end subroutine + + subroutine write2DArrayMPIDist(this, object, descr, block_type) + class(writerMPI) :: this + class(*), intent(in) :: object(:,:) + integer, intent(in) :: descr(9) ! Description array outputted from co_block_type_init + type(MPI_Datatype), intent(in) :: block_type ! subarray type outputed from co_block_type_init + + type(MPI_Datatype) :: mpiType + integer :: byteSize, globalSize, ierr + integer(kind = MPI_OFFSET_KIND) :: arrSizeBytes + + integer :: dims(2) + + dims(:) = descr(3:4) + globalSize = dims(1)*dims(2) + + call getMPIVarInfo(object(1,1), byteSize, mpiType) + arrSizeBytes = globalSize*byteSize + + !print *, globalSize, arrSizeBytes, byteSize, mpiType + + if (this%rank == 0) then + ! write first and last bookends containing array byte size + call MPI_File_write(this%fileh, arrSizeBytes, 1, MPI_INTEGER, & + MPI_STATUS_IGNORE, ierr) + call MPI_File_seek(this%fileh, arrSizeBytes, MPI_SEEK_CUR, ierr) + call MPI_File_write(this%fileh, arrSizeBytes, 1, MPI_INTEGER, & + MPI_STATUS_IGNORE, ierr) + endif + ! offset first bookend + this%offset = this%offset + 4 + ! Set file view including offset + call MPI_File_set_view(this%fileh, this%offset, mpiType, block_type, & + 'native', MPI_INFO_NULL, ierr) + ! Write array in parallel + call MPI_File_write_all(this%fileh, object, size(object), mpiType, & + MPI_STATUS_IGNORE, ierr) + ! Set offset and reset file view + this%offset = this%offset + arrSizeBytes + 4 + call MPI_File_set_view(this%fileh, this%offset, MPI_BYTE, MPI_BYTE, & + 'native', MPI_INFO_NULL, ierr) end subroutine end module From b76334d0b54e6be116241e10551a56456b278ec4 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Wed, 30 Jun 2021 15:00:55 +0100 Subject: [PATCH 25/40] Add another test case to MPI writer along with some comments --- test/unit/test_mpi_io.pf | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/test/unit/test_mpi_io.pf b/test/unit/test_mpi_io.pf index 3196801..c6792b3 100644 --- a/test/unit/test_mpi_io.pf +++ b/test/unit/test_mpi_io.pf @@ -92,13 +92,17 @@ module test_mpi_io ! Test writing another array call writer%write(array2D, array2D_descr, array2D_block_type) - call writer%close() + ! Test writing something after 2nd array + true_integer = 5 + call writer%write(true_integer) ! int - open(newunit=iounit, iostat=stat, action='read', file=fname, \ - form=form, access=access, status=status, position=position) + call writer%close() - ! Only run test on main process + ! Only test result on main process if(rank == 0) then + open(newunit=iounit, iostat=stat, action='read', file=fname, & + form=form, access=access, status=status, position=position) + read(iounit) in_integer @assertTrue(in_integer == true_integer) @@ -125,6 +129,10 @@ module test_mpi_io end do end do + read(iounit) in_integer + @assertTrue(in_integer == true_integer) + + ! Remove test file if (stat == 0) close(iounit, status='delete') endif From 4564b075121c738d1e7eac15718913e759c251b2 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 1 Jul 2021 13:14:46 +0100 Subject: [PATCH 26/40] Refactor reader & writer into one single type --- io_handler_base.f90 | 64 +++++++++++ writer_ftn.f90 => io_handler_ftn.f90 | 92 ++++++++++++---- writer_mpi.f90 => io_handler_mpi.f90 | 77 ++++++++++---- makefile | 14 +-- reader_base.f90 | 34 ------ reader_ftn.f90 | 154 --------------------------- reader_mpi.f90 | 50 --------- test/unit/makefile | 4 +- test/unit/test_io.pf | 46 ++++---- test/unit/test_mpi_io.pf | 30 +++--- writer_base.f90 | 45 -------- 11 files changed, 233 insertions(+), 377 deletions(-) create mode 100644 io_handler_base.f90 rename writer_ftn.f90 => io_handler_ftn.f90 (62%) rename writer_mpi.f90 => io_handler_mpi.f90 (76%) delete mode 100644 reader_base.f90 delete mode 100644 reader_ftn.f90 delete mode 100644 reader_mpi.f90 delete mode 100644 writer_base.f90 diff --git a/io_handler_base.f90 b/io_handler_base.f90 new file mode 100644 index 0000000..6d10569 --- /dev/null +++ b/io_handler_base.f90 @@ -0,0 +1,64 @@ +module io_handler_base + use mpi_aux + + implicit none + + type, abstract :: ioHandlerBase + contains + generic :: write => writeScalar, write1DArray, write2DArray, write2DArrayDist + procedure(writeScalar), deferred :: writeScalar + procedure(write1DArray), deferred :: write1DArray + procedure(write2DArray), deferred :: write2DArray + procedure(write2DArrayDist), deferred :: write2DArrayDist + generic :: read => readScalar, read1DArray, read2DArray + procedure(readScalar), deferred :: readScalar + procedure(read1DArray), deferred :: read1DArray + procedure(read2DArray), deferred :: read2DArray + end type ioHandlerBase + + abstract interface + subroutine writeScalar(this, object) + import ioHandlerBase + class(ioHandlerBase) :: this + class(*), intent(in) :: object + end subroutine + subroutine write1DArray(this, object) + import ioHandlerBase + class(ioHandlerBase) :: this + class(*), dimension(:), intent(in) :: object + end subroutine + subroutine write2DArray(this, object) + import ioHandlerBase + class(ioHandlerBase) :: this + class(*), dimension(:,:), intent(in) :: object + end subroutine + subroutine write2DArrayDist(this, object, descr, block_type) + import ioHandlerBase + import MPI_Datatype + class(ioHandlerBase) :: this + class(*), dimension(:,:), intent(in) :: object + integer, intent(in) :: descr(9) + type(MPI_Datatype), intent(in) :: block_type + end subroutine + subroutine readScalar(this, object) + import ioHandlerBase + class(ioHandlerBase) :: this + class(*), intent(out) :: object + end subroutine + subroutine read1DArray(this, object) + import ioHandlerBase + class(ioHandlerBase) :: this + class(*), dimension(:), intent(out) :: object + end subroutine + subroutine read2DArray(this, object) + import ioHandlerBase + class(ioHandlerBase) :: this + class(*), dimension(:,:), intent(out) :: object + end subroutine + end interface + + private + + public :: ioHandlerBase + +end module diff --git a/writer_ftn.f90 b/io_handler_ftn.f90 similarity index 62% rename from writer_ftn.f90 rename to io_handler_ftn.f90 index 1035f70..13a3aab 100644 --- a/writer_ftn.f90 +++ b/io_handler_ftn.f90 @@ -1,13 +1,13 @@ #include "errors.fpp" -module writer_ftn +module io_handler_ftn use mpi_aux - use writer_base + use io_handler_base use errors implicit none - type, extends(writerBase) :: writerFTN + type, extends(ioHandlerBase) :: ioHandlerFTN integer :: iounit = 0 integer :: stat = 0 logical :: isOpen = .false. @@ -16,23 +16,26 @@ module writer_ftn procedure :: write1DArray => write1DArrayFTN procedure :: write2DArray => write2DArrayFTN procedure :: write2DArrayDist => write2DArrayFTNDist + procedure :: readScalar => readScalarFTN + procedure :: read1DArray => read1DArrayFTN + procedure :: read2DArray => read2DArrayFTN procedure :: open procedure :: close - final :: destroyWriterFTN - end type writerFTN + final :: destroyIoHandlerFTN + end type ioHandlerFTN ! Constructor - interface writerFTN - procedure :: newWriterFTN - end interface writerFTN + interface ioHandlerFTN + procedure :: newIoHandlerFTN + end interface ioHandlerFTN private - public :: writerFTN + public :: ioHandlerFTN contains - type(writerFTN) function newWriterFTN(fname, err, position, status, form, access) result(this) + type(ioHandlerFTN) function newIoHandlerFTN(fname, err, position, status, form, access) result(this) ! writer FTN constructor type(ErrorType), intent(inout) :: err character (len = *), intent(in) :: fname @@ -45,15 +48,16 @@ type(writerFTN) function newWriterFTN(fname, err, position, status, form, access call this%open(fname, err, position, status, form, access) end function - subroutine destroyWriterFTN(this) - type(writerFTN) :: this + subroutine destroyIoHandlerFTN(this) + type(ioHandlerFTN) :: this call this%close() end subroutine - subroutine open(this, fname, err, position, status, form, access) - class(writerFTN) :: this + subroutine open(this, fname, err, action, position, status, form, access) + class(ioHandlerFTN) :: this type(ErrorType), intent(inout) :: err character (len = *), intent(in) :: fname + character (len = *), intent(in) :: action character (len = *), intent(in), optional :: position, status, form, access character (len = 20) :: positionVal, statusVal, formVal, accessVal @@ -88,7 +92,7 @@ subroutine open(this, fname, err, position, status, form, access) print *, "Opening ", fname, " with ", \ positionVal, statusVal, formVal, accessVal - open(newunit=this%iounit, action='write',\ + open(newunit=this%iounit, action=action,\ form=formVal, position=positionVal, status=statusVal, file=fname,\ iostat=this%stat) @@ -100,7 +104,7 @@ subroutine open(this, fname, err, position, status, form, access) end subroutine subroutine close(this) - class(writerFTN) :: this + class(ioHandlerFTN) :: this if (this%isOpen) then close(this%iounit) this%isOpen = .false. @@ -108,7 +112,7 @@ subroutine close(this) end subroutine subroutine writeScalarFTN(this, object) - class(writerFTN) :: this + class(ioHandlerFTN) :: this class(*), intent(in) :: object print *, "writing object with FTN IO" select type(object) @@ -124,7 +128,7 @@ subroutine writeScalarFTN(this, object) end subroutine subroutine write1DArrayFTN(this, object) - class(writerFTN) :: this + class(ioHandlerFTN) :: this class(*), dimension(:), intent(in) :: object print *, "writing 1D array with FTN IO" select type(object) @@ -140,7 +144,7 @@ subroutine write1DArrayFTN(this, object) end subroutine subroutine write2DArrayFTN(this, object) - class(writerFTN) :: this + class(ioHandlerFTN) :: this class(*), dimension(:,:), intent(in) :: object print *, "writing 2D array with FTN IO" select type(object) @@ -156,10 +160,58 @@ subroutine write2DArrayFTN(this, object) end subroutine subroutine write2DArrayFTNDist(this, object, descr, block_type) - class(writerFTN) :: this + class(ioHandlerFTN) :: this class(*), dimension(:,:), intent(in) :: object integer, intent(in) :: descr(9) type(MPI_Datatype), intent(in) :: block_type print *, "ERROR: tried to write distributed array using fortran writer. Use MPI writer instead." end subroutine + + subroutine readScalarFTN(this, object) + class(ioHandlerFTN) :: this + class(*), intent(out) :: object + print *, "reading object with FTN IO" + select type(object) + type is (integer) + read(this%iounit) object + type is (real) + read(this%iounit) object + type is (complex) + read(this%iounit) object + class default + print *, "Unsupported type!" + end select + end subroutine + + subroutine read1DArrayFTN(this, object) + class(ioHandlerFTN) :: this + class(*), dimension(:), intent(out) :: object + print *, "reading 1D array with FTN IO" + select type(object) + type is (integer) + read(this%iounit) object + type is (real) + read(this%iounit) object + type is (complex) + read(this%iounit) object + class default + print *, "Unsupported type!" + end select + end subroutine + + subroutine read2DArrayFTN(this, object) + class(ioHandlerFTN) :: this + class(*), dimension(:,:), intent(out) :: object + print *, "reading 2D array with FTN IO" + select type(object) + type is (integer) + read(this%iounit) object + type is (real) + read(this%iounit) object + type is (complex) + read(this%iounit) object + class default + print *, "Unsupported type!" + end select + end subroutine end module diff --git a/writer_mpi.f90 b/io_handler_mpi.f90 similarity index 76% rename from writer_mpi.f90 rename to io_handler_mpi.f90 index 7a59c58..f0dabf7 100644 --- a/writer_mpi.f90 +++ b/io_handler_mpi.f90 @@ -1,14 +1,14 @@ #include "errors.fpp" -module writer_mpi +module io_handler_mpi use mpi_f08 use mpi_aux - use writer_base + use io_handler_base use errors implicit none - type, extends(writerBase) :: writerMPI + type, extends(ioHandlerBase) :: ioHandlerMPI integer (kind=MPI_Offset_kind) :: offset = 0 integer :: rank = 0 type(MPI_File) :: fileh @@ -18,22 +18,25 @@ module writer_mpi procedure :: write1DArray => write1DArrayMPI procedure :: write2DArray => write2DArrayMPI procedure :: write2DArrayDist => write2DArrayMPIDist + procedure :: readScalar => readScalarMPI + procedure :: read1DArray => read1DArrayMPI + procedure :: read2DArray => read2DArrayMPI procedure :: open procedure :: close - final :: destroyWriterMPI - end type writerMPI + final :: destroyIoHandlerMPI + end type ioHandlerMPI - interface writerMPI - procedure :: newWriterMPI - end interface writerMPI + interface ioHandlerMPI + procedure :: newIoHandlerMPI + end interface ioHandlerMPI private - public :: writerMPI + public :: ioHandlerMPI contains - type(writerMPI) function newWriterMPI(fname, err, position, status, form, access) result(this) + type(ioHandlerMPI) function newIoHandlerMPI(fname, err, position, status, form, access) result(this) ! writer MPI constructor type(ErrorType), intent(inout) :: err character (len = *), intent(in) :: fname @@ -42,14 +45,14 @@ type(writerMPI) function newWriterMPI(fname, err, position, status, form, access call this%open(fname, err, position, status, form, access) end function - subroutine destroyWriterMPI(this) - type(writerMPI) :: this + subroutine destroyIoHandlerMPI(this) + type(ioHandlerMPI) :: this call this%close() end subroutine subroutine open(this, fname, err, position, status, form, access) ! writer MPI constructor - class(writerMPI) :: this + class(ioHandlerMPI) :: this type(ErrorType), intent(inout) :: err character (len = *), intent(in) :: fname character (len = *), intent(in), optional :: position, status, form, access @@ -96,7 +99,7 @@ subroutine open(this, fname, err, position, status, form, access) end subroutine open subroutine close(this) - class(writerMPI) :: this + class(ioHandlerMPI) :: this integer :: ierr if (this%isOpen) then call MPI_File_close(this%fileh, ierr) @@ -135,7 +138,7 @@ subroutine getMPIVarInfo(object, byteSize, mpiType) end subroutine subroutine writeScalarMPI(this, object) - class(writerMPI) :: this + class(ioHandlerMPI) :: this class(*), intent(in) :: object integer :: byteSize, ierr @@ -157,19 +160,19 @@ subroutine writeScalarMPI(this, object) end subroutine subroutine write1DArrayMPI(this, object) - class(writerMPI) :: this + class(ioHandlerMPI) :: this class(*), intent(in) :: object(:) print *, "ERROR: 1D array saving not currently supported" end subroutine subroutine write2DArrayMPI(this, object) - class(writerMPI) :: this + class(ioHandlerMPI) :: this class(*), intent(in) :: object(:,:) print *, "ERROR: Writing non-distributed array using MPI writer not supported." end subroutine subroutine write2DArrayMPIDist(this, object, descr, block_type) - class(writerMPI) :: this + class(ioHandlerMPI) :: this class(*), intent(in) :: object(:,:) integer, intent(in) :: descr(9) ! Description array outputted from co_block_type_init type(MPI_Datatype), intent(in) :: block_type ! subarray type outputed from co_block_type_init @@ -186,17 +189,15 @@ subroutine write2DArrayMPIDist(this, object, descr, block_type) call getMPIVarInfo(object(1,1), byteSize, mpiType) arrSizeBytes = globalSize*byteSize - !print *, globalSize, arrSizeBytes, byteSize, mpiType - if (this%rank == 0) then - ! write first and last bookends containing array byte size + ! write first and last bookends containing array size in bytes call MPI_File_write(this%fileh, arrSizeBytes, 1, MPI_INTEGER, & MPI_STATUS_IGNORE, ierr) call MPI_File_seek(this%fileh, arrSizeBytes, MPI_SEEK_CUR, ierr) call MPI_File_write(this%fileh, arrSizeBytes, 1, MPI_INTEGER, & MPI_STATUS_IGNORE, ierr) endif - ! offset first bookend + ! Offset first bookend this%offset = this%offset + 4 ! Set file view including offset call MPI_File_set_view(this%fileh, this%offset, mpiType, block_type, & @@ -204,10 +205,40 @@ subroutine write2DArrayMPIDist(this, object, descr, block_type) ! Write array in parallel call MPI_File_write_all(this%fileh, object, size(object), mpiType, & MPI_STATUS_IGNORE, ierr) - ! Set offset and reset file view + ! Offset by size of array and end bookend integer this%offset = this%offset + arrSizeBytes + 4 + ! Reset file view back to regular ol bytes call MPI_File_set_view(this%fileh, this%offset, MPI_BYTE, MPI_BYTE, & 'native', MPI_INFO_NULL, ierr) end subroutine + subroutine readScalarMPI(this, object) + class(ioHandlerMPI) :: this + class(*), intent(out) :: object + print *, "reading object to MPI IO" + ! Example object handling + select type(object) + type is (integer) + print *, object + type is (real) + print *, object + type is (complex) + print *, object + class default + print *, "Unsupported type!" + end select + end subroutine + + subroutine read1DArrayMPI(this, object) + class(ioHandlerMPI) :: this + class(*), dimension(:), intent(out) :: object + print *, "reading 1D array to MPI IO" + end subroutine + + subroutine read2DArrayMPI(this, object) + class(ioHandlerMPI) :: this + class(*), dimension(:,:), intent(out) :: object + print *, "reading 2D array to MPI IO" + end subroutine + end module diff --git a/makefile b/makefile index 4a4672a..aae3620 100644 --- a/makefile +++ b/makefile @@ -96,11 +96,10 @@ SRCS := timer.f90 accuracy.f90 diag.f90 dipole.f90 extfield.f90 fields.f90 fwigx pot_abcd.f90 pot_c2h4.f90 pot_c2h6.f90 pot_c3h6.f90 pot_ch3oh.f90 \ pot_xy2.f90 pot_xy3.f90 pot_xy4.f90 pot_zxy2.f90 pot_zxy3.f90 \ prop_xy2.f90 prop_xy2_quad.f90 prop_xy2_spinrot.f90 prop_xy2_spinspin.f90 \ - writer_base.f90 writer_ftn.f90 \ - reader_base.f90 reader_ftn.f90 \ + io_handler_base.f90 io_handler_ftn.f90 \ refinement.f90 richmol_data.f90 rotme_cart_tens.f90 symmetry.f90 tran.f90 trove.f90 $(pot_user).f90 ifdef USE_MPI - SRCS += writer_mpi.f90 reader_mpi.f90 + SRCS += io_handler_mpi.f90 endif OBJS := ${SRCS:.f90=.o} @@ -219,9 +218,6 @@ prop_xy2.o: prop_xy2.f90 accuracy.o moltype.o timer.o pot_xy2.o prop_xy2_quad.o: prop_xy2_quad.f90 accuracy.o moltype.o timer.o pot_xy2.o prop_xy2_spinrot.o: prop_xy2_spinrot.f90 accuracy.o moltype.o pot_xy2.o timer.o prop_xy2_spinspin.o: prop_xy2_spinspin.f90 accuracy.o moltype.o pot_xy2.o timer.o -reader_base.o: reader_base.f90 mpi_aux.o -reader_ftn.o: reader_ftn.f90 reader_base.o mpi_aux.o -reader_mpi.o: reader_mpi.f90 reader_base.o mpi_aux.o refinement.o: refinement.f90 accuracy.o fields.o timer.o molecules.o moltype.o symmetry.o lapack.o tran.o richmol_data.o: richmol_data.f90 accuracy.o timer.o rotme_cart_tens.o: rotme_cart_tens.f90 accuracy.o timer.o fwigxjpf.o moltype.o accuracy.o @@ -229,6 +225,6 @@ symmetry.o: symmetry.f90 accuracy.o timer.o timer.o: timer.f90 accuracy.o tran.o: tran.f90 accuracy.o timer.o me_numer.o molecules.o fields.o moltype.o symmetry.o perturbation.o mpi_aux.o trove.o: trove.f90 accuracy.o fields.o perturbation.o symmetry.o timer.o moltype.o dipole.o refinement.o tran.o extfield.o -writer_base.o: writer_base.f90 mpi_aux.o -writer_ftn.o: writer_ftn.f90 writer_base.o errors.o mpi_aux.o -writer_mpi.o: writer_mpi.f90 writer_base.o mpi_aux.o +io_handler_base.o: io_handler_base.f90 mpi_aux.o +io_handler_ftn.o: io_handler_ftn.f90 io_handler_base.o errors.o mpi_aux.o +io_handler_mpi.o: io_handler_mpi.f90 io_handler_base.o mpi_aux.o diff --git a/reader_base.f90 b/reader_base.f90 deleted file mode 100644 index 9f316f8..0000000 --- a/reader_base.f90 +++ /dev/null @@ -1,34 +0,0 @@ -module reader_base - implicit none - - type, abstract :: readerBase - contains - generic :: read => readScalar, read1DArray, read2DArray - procedure(readScalar), deferred :: readScalar - procedure(read1DArray), deferred :: read1DArray - procedure(read2DArray), deferred :: read2DArray - end type readerBase - - abstract interface - subroutine readScalar(this, object) - import readerBase - class(readerBase) :: this - class(*), intent(out) :: object - end subroutine - subroutine read1DArray(this, object) - import readerBase - class(readerBase) :: this - class(*), dimension(:), intent(out) :: object - end subroutine - subroutine read2DArray(this, object) - import readerBase - class(readerBase) :: this - class(*), dimension(:,:), intent(out) :: object - end subroutine - end interface - - private - - public :: readerBase - -end module diff --git a/reader_ftn.f90 b/reader_ftn.f90 deleted file mode 100644 index d1a0ada..0000000 --- a/reader_ftn.f90 +++ /dev/null @@ -1,154 +0,0 @@ -#include "errors.fpp" - -module reader_ftn - use reader_base - use errors - - implicit none - - type, extends(readerBase) :: readerFTN - integer :: iounit = 0 - integer :: stat = 0 - logical :: isOpen = .false. - contains - procedure :: readScalar => readScalarFTN - procedure :: read1DArray => read1DArrayFTN - procedure :: read2DArray => read2DArrayFTN - procedure :: open - procedure :: close - final :: destroyReaderFTN - end type readerFTN - - interface readerFTN - procedure :: newReaderFTN - end interface readerFTN - - private - - public :: readerFTN - - contains - - type(readerFTN) function newReaderFTN(fname, err, position, status, form, access) result(this) - ! reader FTN constructor - type(ErrorType), intent(inout) :: err - character (len = *), intent(in) :: fname - character (len = *), intent(in), optional :: position, status, form, access - - this%isOpen = .false. - this%stat = 0 - this%iounit = 0 - - call this%open(fname, err, position, status, form, access) - end function - - subroutine destroyReaderFTN(this) - type(readerFTN) :: this - call this%close() - end subroutine - - subroutine open(this, fname, err, position, status, form, access) - class(readerFTN) :: this - type(ErrorType), intent(inout) :: err - character (len = *), intent(in) :: fname - character (len = *), intent(in), optional :: position, status, form, access - character (len = 20) :: positionVal, statusVal, formVal, accessVal - - if (this%isOpen) then - RAISE_ERROR("ERROR: Tried to open second file", err) - endif - - if (present(position)) then - positionVal = position - else - positionVal = 'asis' - end if - - if (present(status)) then - statusVal = status - else - statusVal = 'unknown' - end if - - if (present(form)) then - formVal = form - else - formVal = 'unformatted' - end if - - if (present(access)) then - accessVal = access - else - accessVal = 'sequential' - end if - - print *, "Opening ", fname, " with ", \ - positionVal, statusVal, formVal, accessVal - - open(newunit=this%iounit, action='read',\ - form=formVal, position=positionVal, status=statusVal, file=fname,\ - iostat=this%stat) - - if (this%stat == 0) then - this%isOpen = .true. - else - RAISE_ERROR("ERROR: Could not open file", err) - endif - end subroutine - - subroutine close(this) - class(readerFTN) :: this - if (this%isOpen) then - close(this%iounit) - this%isOpen = .false. - endif - end subroutine - - subroutine readScalarFTN(this, object) - class(readerFTN) :: this - class(*), intent(out) :: object - print *, "reading object with FTN IO" - select type(object) - type is (integer) - read(this%iounit) object - type is (real) - read(this%iounit) object - type is (complex) - read(this%iounit) object - class default - print *, "Unsupported type!" - end select - end subroutine - - subroutine read1DArrayFTN(this, object) - class(readerFTN) :: this - class(*), dimension(:), intent(out) :: object - print *, "reading 1D array with FTN IO" - select type(object) - type is (integer) - read(this%iounit) object - type is (real) - read(this%iounit) object - type is (complex) - read(this%iounit) object - class default - print *, "Unsupported type!" - end select - end subroutine - - subroutine read2DArrayFTN(this, object) - class(readerFTN) :: this - class(*), dimension(:,:), intent(out) :: object - print *, "reading 2D array with FTN IO" - select type(object) - type is (integer) - read(this%iounit) object - type is (real) - read(this%iounit) object - type is (complex) - read(this%iounit) object - class default - print *, "Unsupported type!" - end select - end subroutine -end module diff --git a/reader_mpi.f90 b/reader_mpi.f90 deleted file mode 100644 index b718a6c..0000000 --- a/reader_mpi.f90 +++ /dev/null @@ -1,50 +0,0 @@ -module reader_mpi - use mpi - use reader_base - - implicit none - - type, extends(readerBase) :: readerMPI - contains - procedure :: readScalar => readScalarMPI - procedure :: read1DArray => read1DArrayMPI - procedure :: read2DArray => read2DArrayMPI - end type readerMPI - - private - - public :: readerMPI - - contains - - subroutine readScalarMPI(this, object) - class(readerMPI) :: this - class(*), intent(out) :: object - print *, "reading object to MPI IO" - ! Example object handling - select type(object) - type is (integer) - print *, object - type is (real) - print *, object - type is (complex) - print *, object - class default - print *, "Unsupported type!" - end select - end subroutine - - subroutine read1DArrayMPI(this, object) - class(readerMPI) :: this - class(*), dimension(:), intent(out) :: object - print *, "reading 1D array to MPI IO" - end subroutine - - subroutine read2DArrayMPI(this, object) - class(readerMPI) :: this - class(*), dimension(:,:), intent(out) :: object - print *, "reading 2D array to MPI IO" - end subroutine - - -end module diff --git a/test/unit/makefile b/test/unit/makefile index ebaa16f..6554ac2 100644 --- a/test/unit/makefile +++ b/test/unit/makefile @@ -14,14 +14,14 @@ LAPACK += -lmkl_blacs_openmpi_lp64 -lmkl_scalapack_lp64 endif test_io_TESTS := test_io.pf -test_io_OTHER_SRCS := $(addprefix $(BASE_DIR)/, writer_ftn.f90 writer_base.f90 reader_ftn.f90 reader_base.f90) +test_io_OTHER_SRCS := $(addprefix $(BASE_DIR)/, io_handler_ftn.f90 io_handler_base.f90 ) $(eval $(call make_pfunit_test,test_io)) ifdef USE_MPI FFLAGS += -DTROVE_USE_MPI_ test_mpi_io_TESTS := test_mpi_io.pf test_mpi_io_OTHER_LIBRARIES := ${LAPACK} -test_mpi_io_OTHER_SRCS := $(addprefix $(BASE_DIR)/, writer_mpi.f90 writer_base.f90 reader_mpi.f90 reader_base.f90 mpi_aux.f90 timer.f90 accuracy.f90) +test_mpi_io_OTHER_SRCS := $(addprefix $(BASE_DIR)/, io_handler_mpi.f90 io_handler_base.f90 mpi_aux.f90 timer.f90 accuracy.f90) $(eval $(call make_pfunit_test,test_mpi_io)) endif diff --git a/test/unit/test_io.pf b/test/unit/test_io.pf index 4a83f34..749c34c 100644 --- a/test/unit/test_io.pf +++ b/test/unit/test_io.pf @@ -2,10 +2,8 @@ module test_io use funit - use writer_base - use writer_ftn - use reader_base - use reader_ftn + use io_handler_base + use io_handler_ftn use errors implicit none @@ -13,8 +11,8 @@ module test_io contains @test - subroutine testFTNWriter() - type(writerFTN) :: writer + subroutine testFTNWriting() + type(ioHandlerFTN) :: ioHandler real, dimension(5) :: array1D real, dimension(5, 5) :: array2D @@ -34,22 +32,22 @@ module test_io integer i, j type(ErrorType) :: err - call writer%open(fname, err, \ - form=form, access=access, status=status, position=position) + call ioHandler%open(fname, err, \ + action='write', form=form, access=access, status=status, position=position) HANDLE_ERROR(err) true_integer = 5 - call writer%write(true_integer) ! int + call ioHandler%write(true_integer) ! int true_real = 4.0 - call writer%write(true_real) ! double + call ioHandler%write(true_real) ! double true_complex = (5.0, 1.0) - call writer%write(true_complex) ! complex + call ioHandler%write(true_complex) ! complex ! Array array1D = (/2, 3, 4, 5, 6/) - call writer%write(array1D) + call ioHandler%write(array1D) ! 2D array do i=1,5 @@ -57,9 +55,9 @@ module test_io array2D(i,j) = i+j end do end do - call writer%write(array2D) + call ioHandler%write(array2D) - call writer%close() + call ioHandler%close() open(newunit=iounit, iostat=stat, action='read', file=fname, \ form=form, access=access, status=status, position=position) @@ -86,8 +84,8 @@ module test_io end subroutine @test - subroutine testFTNReader() - type(readerFTN) :: reader + subroutine testFTNioHandler() + type(ioHandlerFTN) :: ioHandler real, dimension(5) :: array1D real, dimension(5, 5) :: array2D @@ -133,17 +131,17 @@ module test_io if (stat == 0) close(iounit) - call reader%open(fname, err, \ - form=form, access=access, status=status, position=position) + call ioHandler%open(fname, err, \ + action='read', form=form, access=access, status=status, position=position) HANDLE_ERROR(err) - call reader%read(in_integer) - call reader%read(in_real) - call reader%read(in_complex) - call reader%read(in_array1D) - call reader%read(in_array2D) + call ioHandler%read(in_integer) + call ioHandler%read(in_real) + call ioHandler%read(in_complex) + call ioHandler%read(in_array1D) + call ioHandler%read(in_array2D) - call reader%close() + call ioHandler%close() @assertTrue(in_integer == true_integer) @assertTrue(in_real == true_real) diff --git a/test/unit/test_mpi_io.pf b/test/unit/test_mpi_io.pf index c6792b3..c6058b3 100644 --- a/test/unit/test_mpi_io.pf +++ b/test/unit/test_mpi_io.pf @@ -4,10 +4,8 @@ module test_mpi_io use funit use mpi_f08 use mpi_aux - use writer_base - use writer_mpi - use reader_base - use reader_mpi + use io_handler_base + use io_handler_mpi use errors use accuracy @@ -18,9 +16,9 @@ module test_mpi_io contains @test - subroutine testMPIWriter() + subroutine testMPIWriting() - type(writerMPI) :: writer + type(ioHandlerMPI) :: ioHandler integer, parameter :: array2DNRow = 4 integer, parameter :: array2DNCol = 3 @@ -51,19 +49,19 @@ module test_mpi_io call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr) if(ierr.ne.0) print *, "Error: could not get rank" - call writer%open(fname, err, \ + call ioHandler%open(fname, err, \ form=form, access=access, status=status, position=position) HANDLE_ERROR(err) ! Test writing scalars true_integer = 5 - call writer%write(true_integer) ! int + call ioHandler%write(true_integer) ! int true_real = 4.0 - call writer%write(true_real) ! double + call ioHandler%write(true_real) ! double true_complex = (5.0, 1.0) - call writer%write(true_complex) ! complex + call ioHandler%write(true_complex) ! complex ! Test writing an array call co_block_type_init(array2D, array2DNCol, array2DNRow, array2D_descr, allocinfo, array2D_block_type) @@ -83,20 +81,20 @@ module test_mpi_io end do end do - call writer%write(array2D, array2D_descr, array2D_block_type) + call ioHandler%write(array2D, array2D_descr, array2D_block_type) ! Test writing something after array true_integer = 5 - call writer%write(true_integer) ! int + call ioHandler%write(true_integer) ! int ! Test writing another array - call writer%write(array2D, array2D_descr, array2D_block_type) + call ioHandler%write(array2D, array2D_descr, array2D_block_type) ! Test writing something after 2nd array true_integer = 5 - call writer%write(true_integer) ! int + call ioHandler%write(true_integer) ! int - call writer%close() + call ioHandler%close() ! Only test result on main process if(rank == 0) then @@ -139,5 +137,5 @@ module test_mpi_io call co_finalize_comms() - end subroutine testMPIWriter + end subroutine testMPIWriting end module diff --git a/writer_base.f90 b/writer_base.f90 deleted file mode 100644 index 1502507..0000000 --- a/writer_base.f90 +++ /dev/null @@ -1,45 +0,0 @@ -module writer_base - use mpi_aux - - implicit none - - type, abstract :: writerBase - contains - generic :: write => writeScalar, write1DArray, write2DArray, write2DArrayDist - procedure(writeScalar), deferred :: writeScalar - procedure(write1DArray), deferred :: write1DArray - procedure(write2DArray), deferred :: write2DArray - procedure(write2DArrayDist), deferred :: write2DArrayDist - end type writerBase - - abstract interface - subroutine writeScalar(this, object) - import writerBase - class(writerBase) :: this - class(*), intent(in) :: object - end subroutine - subroutine write1DArray(this, object) - import writerBase - class(writerBase) :: this - class(*), dimension(:), intent(in) :: object - end subroutine - subroutine write2DArray(this, object) - import writerBase - class(writerBase) :: this - class(*), dimension(:,:), intent(in) :: object - end subroutine - subroutine write2DArrayDist(this, object, descr, block_type) - import writerBase - import MPI_Datatype - class(writerBase) :: this - class(*), dimension(:,:), intent(in) :: object - integer, dimension(9), intent(in) :: descr - type(MPI_Datatype), intent(in) :: block_type - end subroutine - end interface - - private - - public :: writerBase - -end module From f23784a18c100c3b05bfd6637f8957b1562f19db Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 1 Jul 2021 14:56:50 +0100 Subject: [PATCH 27/40] Integrate fortran writer into writing of contr_matelem.chk in perturbation --- io_handler_ftn.f90 | 26 +++++++++---- perturbation.f90 | 95 ++++++++++++++++++++++++++++++++++++++-------- 2 files changed, 98 insertions(+), 23 deletions(-) diff --git a/io_handler_ftn.f90 b/io_handler_ftn.f90 index 13a3aab..4c4ddd7 100644 --- a/io_handler_ftn.f90 +++ b/io_handler_ftn.f90 @@ -4,6 +4,7 @@ module io_handler_ftn use mpi_aux use io_handler_base use errors + use iso_fortran_env implicit none @@ -35,17 +36,18 @@ module io_handler_ftn contains - type(ioHandlerFTN) function newIoHandlerFTN(fname, err, position, status, form, access) result(this) + type(ioHandlerFTN) function newIoHandlerFTN(fname, err, action, position, status, form, access) result(this) ! writer FTN constructor type(ErrorType), intent(inout) :: err character (len = *), intent(in) :: fname + character (len = *), intent(in) :: action character (len = *), intent(in), optional :: position, status, form, access this%isOpen = .false. this%stat = 0 this%iounit = 0 - call this%open(fname, err, position, status, form, access) + call this%open(fname, err, action, position, status, form, access) end function subroutine destroyIoHandlerFTN(this) @@ -89,8 +91,8 @@ subroutine open(this, fname, err, action, position, status, form, access) accessVal = 'sequential' end if - print *, "Opening ", fname, " with ", \ - positionVal, statusVal, formVal, accessVal + print *, "Opening ", trim(fname), " with ", \ + trim(positionVal), " ", trim(statusVal), " ", trim(formVal), " ", trim(accessVal) open(newunit=this%iounit, action=action,\ form=formVal, position=positionVal, status=statusVal, file=fname,\ @@ -114,7 +116,7 @@ subroutine close(this) subroutine writeScalarFTN(this, object) class(ioHandlerFTN) :: this class(*), intent(in) :: object - print *, "writing object with FTN IO" + print *, "writing scalar object with FTN IO" select type(object) type is (integer) write(this%iounit) object @@ -122,6 +124,8 @@ subroutine writeScalarFTN(this, object) write(this%iounit) object type is (complex) write(this%iounit) object + type is (character(len=*)) + write(this%iounit) object class default print *, "ERROR: Tried to write unsupported type" end select @@ -148,11 +152,17 @@ subroutine write2DArrayFTN(this, object) class(*), dimension(:,:), intent(in) :: object print *, "writing 2D array with FTN IO" select type(object) - type is (integer) + type is (integer(int32)) write(this%iounit) object - type is (real) + type is (integer(int64)) write(this%iounit) object - type is (complex) + type is (real(real32)) + write(this%iounit) object + type is (real(real64)) + write(this%iounit) object + type is (complex(kind=8)) + write(this%iounit) object + type is (complex(kind=16)) write(this%iounit) object class default print *, "ERROR: Tried to write unsupported type" diff --git a/perturbation.f90 b/perturbation.f90 index 8a20d54..5a6bbbc 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -2,6 +2,8 @@ ! This unit is not the perturbation theory anymore, it solves the Schroedinger equation ! variationally. ! +#include "errors.fpp" + module perturbation use accuracy use molecules, only : MOrepres_arkT,MLsymmetry_transform_func,polintark,MLrotsymmetry_func,MLrotsymmetry_generate @@ -13,6 +15,9 @@ module perturbation use symmetry , only : SymmetryInitialize,sym use me_numer use diag + use io_handler_base + use io_handler_ftn + use errors ! use omp_lib @@ -16167,6 +16172,9 @@ subroutine PTcontracted_matelem_class(jrot) ! type(PTcoeffsT) :: tmat(PT%Nclasses),mat_tt(PT%Nclasses) type(PTcoeffT),pointer :: fl + + class(ioHandlerBase), allocatable :: ioHandler + type(ErrorType) :: err ! ! call TimerStart('Contracted matelements-class') @@ -16301,12 +16309,13 @@ subroutine PTcontracted_matelem_class(jrot) else call IOStart(trim(job_is),chkptIO) ! - open(chkptIO,form='unformatted',action='write',position='rewind',status='replace',file=job%kinetmat_file) - write(chkptIO) 'Start Kinetic part' + allocate(ioHandler, source=ioHandlerFTN(job%kinetmat_file, err, action='write', position='rewind', status='replace', form='unformatted')) + HANDLE_ERROR(err) + call ioHandler%write('Start Kinetic part') ! ! store the bookkeeping information about the contr. basis set ! - call PTstore_icontr_cnu(PT%Maxcontracts,chkptIO,job%IOkinet_action) + call PTstore_icontr_cnu_new(PT%Maxcontracts,ioHandler,job%IOkinet_action) ! endif endif @@ -16495,7 +16504,7 @@ subroutine PTcontracted_matelem_class(jrot) endif #endif else - write(chkptIO) 'g_rot' + call ioHandler%write('g_rot') endif ! endif @@ -16562,7 +16571,7 @@ subroutine PTcontracted_matelem_class(jrot) if (trim(job%kinetmat_format).eq.'MPIIO') then call co_write_matrix_distr(grot_t,mdimen, startdim, enddim,chkptMPIIO) else - write(chkptIO) grot_t + call ioHandler%write(grot_t) endif ! endif @@ -16585,7 +16594,7 @@ subroutine PTcontracted_matelem_class(jrot) endif #endif else - write(chkptIO) 'g_cor' + call ioHandler%write('g_cor') endif ! endif @@ -16686,7 +16695,7 @@ subroutine PTcontracted_matelem_class(jrot) if (trim(job%kinetmat_format).eq.'MPIIO') then call co_write_matrix_distr(gcor_t,mdimen, startdim, enddim,chkptMPIIO) else - write(chkptIO) gcor_t + call ioHandler%write(gcor_t) endif ! endif @@ -16760,24 +16769,24 @@ subroutine PTcontracted_matelem_class(jrot) ! ! store the rotational matrix elements ! - write(chkptIO) 'g_rot' + call ioHandler%write('g_rot') ! do k1 = 1,3 do k2 = 1,3 ! - write(chkptIO) grot_(k1,k2,:,:) + call ioHandler%write(grot_(k1,k2,:,:)) ! enddo enddo ! - write(chkptIO) 'g_cor' + call ioHandler%write('g_cor') ! ! store the Coriolis matrix elements ! do k1 = 1,PT%Nmodes do k2 = 1,3 ! - write(chkptIO) gcor_(k1,k2,:,:) + call ioHandler%write(gcor_(k1,k2,:,:)) ! enddo enddo @@ -17100,8 +17109,8 @@ subroutine PTcontracted_matelem_class(jrot) call co_write_matrix_distr(hvib%me,mdimen, startdim, enddim,chkptMPIIO) #endif else - write(chkptIO) 'hvib' - write(chkptIO) hvib%me + call ioHandler%write('hvib') + call ioHandler%write(hvib%me) endif ! endif @@ -17124,8 +17133,8 @@ subroutine PTcontracted_matelem_class(jrot) call MPI_File_close(chkptMPIIO, ierr) #endif else - write(chkptIO) 'End Kinetic part' - close(chkptIO,status='keep') + call ioHandler%write('End Kinetic part') + deallocate(ioHandler) endif ! endif @@ -35007,6 +35016,62 @@ subroutine PTstore_icontr_cnu(Maxcontracts,iunit,dir) ! end subroutine PTstore_icontr_cnu + subroutine PTstore_icontr_cnu_new(Maxcontracts,ioHandler,dir) + + integer(ik),intent(in) :: Maxcontracts + class(ioHandlerBase), intent(in) :: ioHandler + character(len=18),intent(in) :: dir + integer(ik) :: alloc + character(len=18) :: buf18 + integer(ik) :: ncontr + integer(ik),allocatable :: imat_t(:,:) + ! + selectcase (trim(dir)) + ! + case ('SAVE') + + call ioHandler%write(Maxcontracts) + call ioHandler%write('icontr_cnu') + call ioHandler%write(PT%icontr_cnu(0:PT%Nclasses,1:Maxcontracts)) + call ioHandler%write('icontr_ideg') + call ioHandler%write(PT%icontr_ideg(0:PT%Nclasses,1:Maxcontracts)) + + case ('APPEND') + ! + stop "APPEND in PTstore_icontr_cnu currently unsupported" + !read(iunit) ncontr + !! + !if (Maxcontracts/=ncontr) then + !write (out,"(' Vib. kinetic checkpoint file ',a)") job%kinetmat_file + !write (out,"(' Actual and stored basis sizes at J=0 do not agree ',2i8)") PT%Maxcontracts,ncontr + !stop 'PTrestore_rot_kinetic_matrix_elements - in file - illegal nroots ' + !end if + !! + !allocate (imat_t(0:PT%Nclasses,ncontr),stat=alloc) + !call ArrayStart('mat_t',alloc,size(imat_t),kind(imat_t)) + !! + !read(iunit) buf18(1:10) + !if (buf18(1:10)/='icontr_cnu') then + !write (out,"(' Vib. kinetic checkpoint file ',a,': icontr_cnu is missing ',a)") job%kinetmat_file,buf18(1:10) + !stop 'PTrestore_rot_kinetic_matrix_elements - in file - icontr_cnu missing' + !end if + !! + !read(iunit) imat_t(0:PT%Nclasses,1:ncontr) + !! + !read(iunit) buf18(1:11) + !if (buf18(1:11)/='icontr_ideg') then + !write (out,"(' Vib. kinetic checkpoint file ',a,': icontr_ideg is missing ',a)") job%kinetmat_file,buf18(1:11) + !stop 'PTrestore_rot_kinetic_matrix_elements - in file - icontr_ideg missing' + !end if + !! + !read(iunit) imat_t(0:PT%Nclasses,1:ncontr) + !! + !deallocate(imat_t) + ! + end select + ! + end subroutine PTstore_icontr_cnu_new + subroutine PTstoreMPI_icontr_cnu(maxcontracts,iunit,dir) use mpi_aux From 7687189342861350e57e1f9207d91cf0b77ffbf9 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 1 Jul 2021 15:19:27 +0100 Subject: [PATCH 28/40] Add writing of strings from MPI writer --- io_handler_mpi.f90 | 51 +++++++++++++++++++++++++++------------- test/unit/test_mpi_io.pf | 19 ++++++++------- 2 files changed, 45 insertions(+), 25 deletions(-) diff --git a/io_handler_mpi.f90 b/io_handler_mpi.f90 index f0dabf7..e1585de 100644 --- a/io_handler_mpi.f90 +++ b/io_handler_mpi.f90 @@ -36,13 +36,14 @@ module io_handler_mpi contains - type(ioHandlerMPI) function newIoHandlerMPI(fname, err, position, status, form, access) result(this) + type(ioHandlerMPI) function newIoHandlerMPI(fname, err, action, position, status, form, access) result(this) ! writer MPI constructor - type(ErrorType), intent(inout) :: err character (len = *), intent(in) :: fname + type(ErrorType), intent(inout) :: err + character (len = *), intent(in) :: action character (len = *), intent(in), optional :: position, status, form, access - call this%open(fname, err, position, status, form, access) + call this%open(fname, err, action, position, status, form, access) end function subroutine destroyIoHandlerMPI(this) @@ -50,11 +51,12 @@ subroutine destroyIoHandlerMPI(this) call this%close() end subroutine - subroutine open(this, fname, err, position, status, form, access) + subroutine open(this, fname, err, action, position, status, form, access) ! writer MPI constructor class(ioHandlerMPI) :: this - type(ErrorType), intent(inout) :: err character (len = *), intent(in) :: fname + type(ErrorType), intent(inout) :: err + character (len = *), intent(in) :: action character (len = *), intent(in), optional :: position, status, form, access character (len = 20) :: positionVal, statusVal, formVal, accessVal integer :: ierr @@ -87,14 +89,21 @@ subroutine open(this, fname, err, position, status, form, access) accessVal = 'sequential' end if - print *, "MPI: Opening ", fname, " with ", \ - positionVal, statusVal, formVal, accessVal + print *, "MPI: Opening ", trim(fname), " with ", \ + trim(positionVal), " ", trim(statusVal), " ", trim(formVal), " ", trim(accessVal) ! FIXME use above flags to change open behaviour call MPI_Comm_rank(MPI_COMM_WORLD, this%rank, ierr) - call MPI_File_open(MPI_COMM_WORLD, fname, MPI_MODE_WRONLY + MPI_MODE_CREATE, MPI_INFO_NULL, this%fileh, ierr) + ! FIXME is there a better way to set MPI_MODE_* flags? + if(trim(action) == 'write') then + call MPI_File_open(MPI_COMM_WORLD, fname, MPI_MODE_WRONLY + MPI_MODE_CREATE, MPI_INFO_NULL, this%fileh, ierr) + else + call MPI_File_open(MPI_COMM_WORLD, fname, MPI_MODE_RDONLY, MPI_INFO_NULL, this%fileh, ierr) + endif + + call MPI_File_set_errhandler(this%fileh, MPI_ERRORS_ARE_FATAL) ! FIXME handle error end subroutine open @@ -115,23 +124,26 @@ subroutine getMPIVarInfo(object, byteSize, mpiType) select type(object) type is (integer(kind=4)) - byteSize = 4 + byteSize = sizeof(object) mpiType = MPI_INTEGER type is (integer(kind=8)) - byteSize = 8 + byteSize = sizeof(object) mpiType = MPI_LONG type is (real(kind=4)) - byteSize = 4 + byteSize = sizeof(object) mpiType = MPI_FLOAT type is (real(kind=8)) - byteSize = 8 + byteSize = sizeof(object) mpiType = MPI_DOUBLE type is (complex(kind=4)) - byteSize = 8 + byteSize = sizeof(object) mpiType = MPI_COMPLEX type is (complex(kind=8)) - byteSize = 16 + byteSize = sizeof(object) mpiType = MPI_DOUBLE_COMPLEX + type is (character(len=*)) + byteSize = sizeof(object) + mpiType = MPI_CHARACTER class default print *, "ERROR: Unknown type" end select @@ -141,19 +153,26 @@ subroutine writeScalarMPI(this, object) class(ioHandlerMPI) :: this class(*), intent(in) :: object - integer :: byteSize, ierr + integer :: byteSize, ierr, length type(MPI_Datatype) :: mpiType call getMPIVarInfo(object, byteSize, mpiType) this%offset = this%offset + 4+byteSize+4 + select type(object) + type is (character(len=*)) + length = len(object) + class default + length = 1 + end select + if (this%rank /= 0) then return end if call MPI_File_write(this%fileh, byteSize, 1, MPI_INTEGER, & MPI_STATUS_IGNORE, ierr) - call MPI_File_write(this%fileh, object, 1, mpiType, & + call MPI_File_write(this%fileh, object, length, mpiType, & MPI_STATUS_IGNORE, ierr) call MPI_File_write(this%fileh, byteSize, 1, MPI_INTEGER, & MPI_STATUS_IGNORE, ierr) diff --git a/test/unit/test_mpi_io.pf b/test/unit/test_mpi_io.pf index c6058b3..a9b78db 100644 --- a/test/unit/test_mpi_io.pf +++ b/test/unit/test_mpi_io.pf @@ -27,9 +27,10 @@ module test_mpi_io integer :: array2D_descr(9) = 0 type(MPI_Datatype) :: array2D_block_type - real :: true_real, in_real - complex :: true_complex, in_complex - integer :: true_integer, in_integer + real :: true_real = 4.0, in_real + complex :: true_complex = (5.0, 1.0), in_complex + integer :: true_integer = 5, in_integer + character (len=11) :: true_str = "test string", in_str integer :: iounit, stat character(len=*), parameter :: fname = "test.dat" @@ -49,19 +50,15 @@ module test_mpi_io call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr) if(ierr.ne.0) print *, "Error: could not get rank" - call ioHandler%open(fname, err, \ + call ioHandler%open(fname, err, action='write', & form=form, access=access, status=status, position=position) HANDLE_ERROR(err) ! Test writing scalars - true_integer = 5 call ioHandler%write(true_integer) ! int - - true_real = 4.0 call ioHandler%write(true_real) ! double - - true_complex = (5.0, 1.0) call ioHandler%write(true_complex) ! complex + call ioHandler%write(true_str) ! string ! Test writing an array call co_block_type_init(array2D, array2DNCol, array2DNRow, array2D_descr, allocinfo, array2D_block_type) @@ -110,6 +107,10 @@ module test_mpi_io read(iounit) in_complex @assertTrue(in_complex == true_complex) + read(iounit) in_str + print *, sizeof(in_str) + @assertTrue(in_str == true_str) + read(iounit) in_array2D do i=1,array2DNRow do j=1,array2DNCol From a475c87ba720687af27a069b145eacf831f4b238 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Fri, 2 Jul 2021 15:54:34 +0100 Subject: [PATCH 29/40] Cleanup io_handler_ftn and fix complex type detection --- io_handler_ftn.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/io_handler_ftn.f90 b/io_handler_ftn.f90 index 4c4ddd7..e203fd0 100644 --- a/io_handler_ftn.f90 +++ b/io_handler_ftn.f90 @@ -91,7 +91,7 @@ subroutine open(this, fname, err, action, position, status, form, access) accessVal = 'sequential' end if - print *, "Opening ", trim(fname), " with ", \ + print *, "FTN: Opening ", trim(fname), " with ", \ trim(positionVal), " ", trim(statusVal), " ", trim(formVal), " ", trim(accessVal) open(newunit=this%iounit, action=action,\ @@ -160,9 +160,9 @@ subroutine write2DArrayFTN(this, object) write(this%iounit) object type is (real(real64)) write(this%iounit) object - type is (complex(kind=8)) + type is (complex(kind=4)) write(this%iounit) object - type is (complex(kind=16)) + type is (complex(kind=8)) write(this%iounit) object class default print *, "ERROR: Tried to write unsupported type" From 0510ec65534403259d745c7b5c54a218b7a7c96c Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Fri, 2 Jul 2021 15:55:50 +0100 Subject: [PATCH 30/40] Add fixtures to test MPI properly, and add test of co_distr_write --- test/unit/test_mpi_io.pf | 110 ++++++++++++++++++++++++++++++++++++--- 1 file changed, 104 insertions(+), 6 deletions(-) diff --git a/test/unit/test_mpi_io.pf b/test/unit/test_mpi_io.pf index a9b78db..f1937c5 100644 --- a/test/unit/test_mpi_io.pf +++ b/test/unit/test_mpi_io.pf @@ -1,8 +1,8 @@ #include "errors.fpp" module test_mpi_io - use funit use mpi_f08 + use funit use mpi_aux use io_handler_base use io_handler_mpi @@ -11,12 +11,40 @@ module test_mpi_io implicit none + @TestCase + type, extends(TestCase) :: TestMPI + contains + procedure :: setUp ! overides generic + procedure :: tearDown ! overrides generic + end type TestMPI + integer,external :: INDXL2G + logical :: is_mpi_initialised = .false. + integer, parameter :: totalTestCount = 2 + integer :: currentTestCount = 0 + contains + subroutine setUp(this) + class(TestMPI), intent(inout) :: this + currentTestCount = currentTestCount + 1 + if (is_mpi_initialised .eqv. .false.) then + call co_init_comms() + is_mpi_initialised = .true. + endif + end subroutine setUp + + subroutine tearDown(this) + class(TestMPI), intent(inout) :: this + if (is_mpi_initialised .eqv. .true. .and. currentTestCount == totalTestCount) then + call co_finalize_comms() + endif + end subroutine tearDown + @test - subroutine testMPIWriting() + subroutine testMPIWriting(this) + class(TestMPI), intent(inout) :: this type(ioHandlerMPI) :: ioHandler @@ -45,8 +73,6 @@ module test_mpi_io integer :: ierr, rank, allocinfo = 0 - call co_init_comms() - call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr) if(ierr.ne.0) print *, "Error: could not get rank" @@ -136,7 +162,79 @@ module test_mpi_io endif - call co_finalize_comms() - end subroutine testMPIWriting + + @test + subroutine testMPIWritingColumnDistArray(this) + class(TestMPI), intent(inout) :: this + type(ioHandlerMPI) :: ioHandler + + integer :: dimen = 12 + integer :: startdim, enddim, blocksize, mdimen_p, mdimen_b, mdimen + integer :: b, icoeff, jcoeff + + integer :: iounit, stat + character(len=*), parameter :: fname = "test.dat" + character(len=*), parameter :: status = "unknown" + character(len=*), parameter :: form = "unformatted" + character(len=*), parameter :: access = "stream" ! Use stream to directly test MPI output + + real(rk), allocatable :: grot_t(:,:) + real(rk), allocatable :: grot_full(:,:) + real(rk),allocatable :: recvbuf(:,:,:) + + integer :: i,j + + type(MPI_File) :: chkptMPIIO + integer :: ierr, rank, allocinfo = 0 + + call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr) + if(ierr.ne.0) print *, "Error: could not get rank" + + call co_init_distr(dimen, startdim, enddim, blocksize) + + mdimen = dimen + mdimen_p = int(1+real(dimen/comm_size)) + mdimen_b = comm_size*mdimen_p + + allocate(recvbuf(mdimen_p,mdimen_p,comm_size)) + allocate(grot_t(mdimen_b,startdim:startdim+mdimen_p-1)) + allocate(grot_full(dimen, dimen)) + + grot_t = 0 + + ! Fill local chunk of symmetric matrix + do b=1,comm_size + if (send_or_recv(b).ge.0) then + do icoeff=startdim,enddim + do jcoeff=((b-1)*mdimen_p)+1,b*mdimen_p + grot_t(jcoeff,icoeff) = jcoeff*icoeff + enddo + enddo + endif + enddo + + ! Distribute between processes and save + call co_distr_data(grot_t, recvbuf, mdimen_p, startdim, enddim) + call MPI_File_open(mpi_comm_world, fname, mpi_mode_wronly+mpi_mode_create, mpi_info_null, chkptMPIIO, ierr) + call co_write_matrix_distr(grot_t, mdimen, startdim, enddim, chkptMPIIO) + call MPI_File_close(chkptMPIIO, ierr) + + ! Check output + if(rank == 0) then + open(newunit=iounit, iostat=stat, action='read', file=fname, & + form=form, access=access, status=status) + + read(iounit) grot_full + + do i=1,dimen + do j=1,dimen + @assertTrue(grot_full(i,j) == i*j) + end do + end do + + close(iounit, status='delete') + endif + + end subroutine testMPIWritingColumnDistArray end module From 65b2c23381329a53d07aec88fb885b36f24d1d49 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Mon, 5 Jul 2021 12:53:41 +0100 Subject: [PATCH 31/40] Add writing of arrays distributed through co_distr_data --- io_handler_base.f90 | 14 ++++++++--- io_handler_ftn.f90 | 22 +++++++++++++++--- io_handler_mpi.f90 | 40 ++++++++++++++++++++++++++++++-- test/unit/test_mpi_io.pf | 50 ++++++++++++++++++++++++++++++++++------ 4 files changed, 111 insertions(+), 15 deletions(-) diff --git a/io_handler_base.f90 b/io_handler_base.f90 index 6d10569..13745bb 100644 --- a/io_handler_base.f90 +++ b/io_handler_base.f90 @@ -5,11 +5,12 @@ module io_handler_base type, abstract :: ioHandlerBase contains - generic :: write => writeScalar, write1DArray, write2DArray, write2DArrayDist + generic :: write => writeScalar, write1DArray, write2DArray, write2DArrayDistBlacs, write2DArrayDistColumn procedure(writeScalar), deferred :: writeScalar procedure(write1DArray), deferred :: write1DArray procedure(write2DArray), deferred :: write2DArray - procedure(write2DArrayDist), deferred :: write2DArrayDist + procedure(write2DArrayDistBlacs), deferred :: write2DArrayDistBlacs + procedure(write2DArrayDistColumn), deferred :: write2DArrayDistColumn generic :: read => readScalar, read1DArray, read2DArray procedure(readScalar), deferred :: readScalar procedure(read1DArray), deferred :: read1DArray @@ -32,7 +33,7 @@ subroutine write2DArray(this, object) class(ioHandlerBase) :: this class(*), dimension(:,:), intent(in) :: object end subroutine - subroutine write2DArrayDist(this, object, descr, block_type) + subroutine write2DArrayDistBlacs(this, object, descr, block_type) import ioHandlerBase import MPI_Datatype class(ioHandlerBase) :: this @@ -40,6 +41,13 @@ subroutine write2DArrayDist(this, object, descr, block_type) integer, intent(in) :: descr(9) type(MPI_Datatype), intent(in) :: block_type end subroutine + subroutine write2DArrayDistColumn(this, object, mdimen) + import ioHandlerBase + import MPI_Datatype + class(ioHandlerBase) :: this + class(*), dimension(:,:), intent(in) :: object + integer, intent(in) :: mdimen + end subroutine subroutine readScalar(this, object) import ioHandlerBase class(ioHandlerBase) :: this diff --git a/io_handler_ftn.f90 b/io_handler_ftn.f90 index e203fd0..c641593 100644 --- a/io_handler_ftn.f90 +++ b/io_handler_ftn.f90 @@ -16,7 +16,8 @@ module io_handler_ftn procedure :: writeScalar => writeScalarFTN procedure :: write1DArray => write1DArrayFTN procedure :: write2DArray => write2DArrayFTN - procedure :: write2DArrayDist => write2DArrayFTNDist + procedure :: write2DArrayDistBlacs => write2DArrayDistBlacsFTN + procedure :: write2DArrayDistColumn => write2DArrayDistColumnFTN procedure :: readScalar => readScalarFTN procedure :: read1DArray => read1DArrayFTN procedure :: read2DArray => read2DArrayFTN @@ -169,12 +170,27 @@ subroutine write2DArrayFTN(this, object) end select end subroutine - subroutine write2DArrayFTNDist(this, object, descr, block_type) + subroutine write2DArrayDistBlacsFTN(this, object, descr, block_type) + ! Write arrays distributed using blacs + class(ioHandlerFTN) :: this class(*), dimension(:,:), intent(in) :: object integer, intent(in) :: descr(9) type(MPI_Datatype), intent(in) :: block_type - print *, "ERROR: tried to write distributed array using fortran writer. Use MPI writer instead." + + ! Using the fortran io_handler means array isn't distributed, just write normally + call this%write2DArray(object) + end subroutine + + subroutine write2DArrayDistColumnFTN(this, object, mdimen) + ! Write arrays distributed as columns using co_distr_data + + class(ioHandlerFTN) :: this + class(*), intent(in) :: object(:,:) + integer, intent(in) :: mdimen ! Dimension of entire distributed array + + ! Using the fortran io_handler means array isn't distributed, just write normally + call this%write2DArray(object) end subroutine subroutine readScalarFTN(this, object) diff --git a/io_handler_mpi.f90 b/io_handler_mpi.f90 index e1585de..86466a3 100644 --- a/io_handler_mpi.f90 +++ b/io_handler_mpi.f90 @@ -17,7 +17,8 @@ module io_handler_mpi procedure :: writeScalar => writeScalarMPI procedure :: write1DArray => write1DArrayMPI procedure :: write2DArray => write2DArrayMPI - procedure :: write2DArrayDist => write2DArrayMPIDist + procedure :: write2DArrayDistBlacs => write2DArrayDistBlacsMPI + procedure :: write2DArrayDistColumn => write2DArrayDistColumnMPI procedure :: readScalar => readScalarMPI procedure :: read1DArray => read1DArrayMPI procedure :: read2DArray => read2DArrayMPI @@ -190,7 +191,7 @@ subroutine write2DArrayMPI(this, object) print *, "ERROR: Writing non-distributed array using MPI writer not supported." end subroutine - subroutine write2DArrayMPIDist(this, object, descr, block_type) + subroutine write2DArrayDistBlacsMPI(this, object, descr, block_type) class(ioHandlerMPI) :: this class(*), intent(in) :: object(:,:) integer, intent(in) :: descr(9) ! Description array outputted from co_block_type_init @@ -231,6 +232,41 @@ subroutine write2DArrayMPIDist(this, object, descr, block_type) 'native', MPI_INFO_NULL, ierr) end subroutine + subroutine write2DArrayDistColumnMPI(this, object, mdimen) + class(ioHandlerMPI) :: this + class(*), intent(in) :: object(:,:) + integer, intent(in) :: mdimen ! Dimension of entire distributed array + + type(MPI_Datatype) :: mpiType + integer :: byteSize, globalSize, ierr, writestat + integer(kind = MPI_OFFSET_KIND) :: arrSizeBytes + + globalSize = mdimen**2 + + call getMPIVarInfo(object(1,1), byteSize, mpiType) + arrSizeBytes = globalSize*byteSize + + ! TODO what if format isn't sequential?? + if (this%rank == 0) then + ! write first and last bookends containing array size in bytes + call MPI_File_write(this%fileh, arrSizeBytes, 1, MPI_INTEGER, & + MPI_STATUS_IGNORE, ierr) + call MPI_File_seek(this%fileh, arrSizeBytes, MPI_SEEK_CUR, ierr) + call MPI_File_write(this%fileh, arrSizeBytes, 1, MPI_INTEGER, & + MPI_STATUS_IGNORE, ierr) + endif + ! Offset first bookend + this%offset = this%offset + 4 + ! Seek to byte after bookend + call MPI_File_seek_shared(this%fileh, this%offset, MPI_SEEK_SET, ierr) + ! Write array in parallel + call MPI_File_write_ordered(this%fileh,object,1,mpitype_column,MPI_STATUS_IGNORE,ierr) + ! Offset by size of array and end bookend integer + this%offset = this%offset + arrSizeBytes + 4 + ! Ensure all file pointers point to end of array + call MPI_File_seek(this%fileh, this%offset, MPI_SEEK_SET, ierr) + end subroutine + subroutine readScalarMPI(this, object) class(ioHandlerMPI) :: this class(*), intent(out) :: object diff --git a/test/unit/test_mpi_io.pf b/test/unit/test_mpi_io.pf index f1937c5..537c347 100644 --- a/test/unit/test_mpi_io.pf +++ b/test/unit/test_mpi_io.pf @@ -107,14 +107,12 @@ module test_mpi_io call ioHandler%write(array2D, array2D_descr, array2D_block_type) ! Test writing something after array - true_integer = 5 call ioHandler%write(true_integer) ! int ! Test writing another array call ioHandler%write(array2D, array2D_descr, array2D_block_type) ! Test writing something after 2nd array - true_integer = 5 call ioHandler%write(true_integer) ! int call ioHandler%close() @@ -175,19 +173,24 @@ module test_mpi_io integer :: iounit, stat character(len=*), parameter :: fname = "test.dat" + character(len=*), parameter :: position = "asis" character(len=*), parameter :: status = "unknown" character(len=*), parameter :: form = "unformatted" - character(len=*), parameter :: access = "stream" ! Use stream to directly test MPI output + character(len=*), parameter :: access = "sequential" real(rk), allocatable :: grot_t(:,:) real(rk), allocatable :: grot_full(:,:) real(rk),allocatable :: recvbuf(:,:,:) + integer :: true_integer = 5, in_integer + integer :: i,j type(MPI_File) :: chkptMPIIO integer :: ierr, rank, allocinfo = 0 + type(ErrorType) :: err + call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr) if(ierr.ne.0) print *, "Error: could not get rank" @@ -216,23 +219,56 @@ module test_mpi_io ! Distribute between processes and save call co_distr_data(grot_t, recvbuf, mdimen_p, startdim, enddim) - call MPI_File_open(mpi_comm_world, fname, mpi_mode_wronly+mpi_mode_create, mpi_info_null, chkptMPIIO, ierr) - call co_write_matrix_distr(grot_t, mdimen, startdim, enddim, chkptMPIIO) - call MPI_File_close(chkptMPIIO, ierr) + + call ioHandler%open(fname, err, action='write', & + form=form, access=access, status=status, position=position) + HANDLE_ERROR(err) + + ! Test writing something before array + call ioHandler%write(true_integer) + + ! Test writing an array + call ioHandler%write(grot_t, mdimen) + + ! Test writing something after array + call ioHandler%write(true_integer) + + ! Test writing another array + call ioHandler%write(grot_t, mdimen) + + ! Test writing something after second array + call ioHandler%write(true_integer) + + call ioHandler%close() ! Check output if(rank == 0) then open(newunit=iounit, iostat=stat, action='read', file=fname, & - form=form, access=access, status=status) + form=form, access=access, status=status, position=position) + + read(iounit) in_integer + @assertTrue(in_integer == true_integer) read(iounit) grot_full + do i=1,dimen + do j=1,dimen + @assertTrue(grot_full(i,j) == i*j) + end do + end do + + read(iounit) in_integer + @assertTrue(in_integer == true_integer) + read(iounit) grot_full do i=1,dimen do j=1,dimen @assertTrue(grot_full(i,j) == i*j) end do end do + read(iounit) in_integer + @assertTrue(in_integer == true_integer) + close(iounit, status='delete') endif From 0d59f524f5d101f38c4a178d7e5c117a4d49fb79 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Mon, 5 Jul 2021 13:33:46 +0100 Subject: [PATCH 32/40] Implement writing of (unsplit) matelem using MPI --- io_handler_mpi.f90 | 24 ++++- perturbation.f90 | 246 +++++++++------------------------------------ tran.f90 | 10 +- 3 files changed, 75 insertions(+), 205 deletions(-) diff --git a/io_handler_mpi.f90 b/io_handler_mpi.f90 index 86466a3..7db62aa 100644 --- a/io_handler_mpi.f90 +++ b/io_handler_mpi.f90 @@ -188,7 +188,29 @@ subroutine write1DArrayMPI(this, object) subroutine write2DArrayMPI(this, object) class(ioHandlerMPI) :: this class(*), intent(in) :: object(:,:) - print *, "ERROR: Writing non-distributed array using MPI writer not supported." + + type(MPI_Datatype) :: mpiType + integer :: byteSize, globalSize, ierr, length + + integer(kind = MPI_OFFSET_KIND) :: arrSizeBytes + + globalSize = size(object) + + call getMPIVarInfo(object(1,1), byteSize, mpiType) + arrSizeBytes = globalSize*byteSize + + this%offset = this%offset + 4 + arrSizeBytes + 4 + + if (this%rank /= 0) then + return + end if + + call MPI_File_write(this%fileh, byteSize, 1, MPI_INTEGER, & + MPI_STATUS_IGNORE, ierr) + call MPI_File_write(this%fileh, object, globalSize, mpiType, & + MPI_STATUS_IGNORE, ierr) + call MPI_File_write(this%fileh, byteSize, 1, MPI_INTEGER, & + MPI_STATUS_IGNORE, ierr) end subroutine subroutine write2DArrayDistBlacsMPI(this, object, descr, block_type) diff --git a/perturbation.f90 b/perturbation.f90 index 5a6bbbc..2c07eab 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -17,6 +17,9 @@ module perturbation use diag use io_handler_base use io_handler_ftn +#ifdef TROVE_USE_MPI_ + use io_handler_mpi +#endif use errors ! use omp_lib @@ -28,7 +31,7 @@ module perturbation public PTcontracted_matelem_class,PTeigenfunction_orthogonality public PThamiltonian_contract,PTget_primitive_matelements,PTDVR_initialize public PTcheck_point_contracted_space,PT_conctracted_rotational_bset - public PTTest_eigensolution,PTanalysis_density,PTstore_icontr_cnu,PTstorempi_icontr_cnu + public PTTest_eigensolution,PTanalysis_density,PTstore_icontr_cnu public PTintcoeffsT,PTrotquantaT,PTNclasses,PTdefine_contr_from_eigenvect,PTeigenT,PTrepresT public PTstore_contr_matelem,PTcontracted_matelem_class_fast,PTstore_contr_matelem_II,PTcontracted_matelem_class_fast_II @@ -16279,45 +16282,17 @@ subroutine PTcontracted_matelem_class(jrot) ! Prepare the checkpoint file ! job_is ='Vib. matrix elements of the rot. kinetic part' - if (trim(job%kinetmat_format).eq.'MPIIO') then -#ifdef TROVE_USE_MPI_ - call MPI_File_open(mpi_comm_world, job%kinetmat_file, mpi_mode_wronly+mpi_mode_create, mpi_info_null, chkptMPIIO, ierr) - - call MPI_File_set_errhandler(chkptMPIIO, MPI_ERRORS_ARE_FATAL) - - mpioffset=0 - - call MPI_File_set_size(chkptMPIIO, mpioffset, ierr) - - call MPI_File_seek(chkptMPIIO, mpioffset, MPI_SEEK_CUR, ierr) - - - if (mpi_rank.eq.0) then !AT - call MPI_File_write(chkptMPIIO,'[MPIIO]',7,mpi_character,mpi_status_ignore,ierr) - call MPI_File_write(chkptMPIIO,'Start Kinetic part',18,mpi_character,mpi_status_ignore,ierr) - call TimerStart('mpiiosingle') !AT - ! - ! store the bookkeeping information about the contr. basis set - ! - call PTstoreMPI_icontr_cnu(PT%Maxcontracts,chkptMPIIO,job%IOkinet_action) + call IOStart(trim(job_is),chkptIO) + ! + allocate(ioHandler, source=ioHandlerFTN(job%kinetmat_file, err, action='write', position='rewind', status='replace', form='unformatted')) + !allocate(ioHandler, source=ioHandlerMPI(job%kinetmat_file, err, action='write', position='rewind', status='replace', form='unformatted')) + HANDLE_ERROR(err) - call TimerStop('mpiiosingle') !AT - endif - call MPI_Barrier(mpi_comm_world, ierr) - call MPI_File_seek_shared(chkptMPIIO, mpioffset, MPI_SEEK_END, ierr) -#endif - else - call IOStart(trim(job_is),chkptIO) - ! - allocate(ioHandler, source=ioHandlerFTN(job%kinetmat_file, err, action='write', position='rewind', status='replace', form='unformatted')) - HANDLE_ERROR(err) - call ioHandler%write('Start Kinetic part') - ! - ! store the bookkeeping information about the contr. basis set - ! - call PTstore_icontr_cnu_new(PT%Maxcontracts,ioHandler,job%IOkinet_action) - ! - endif + call ioHandler%write('Start Kinetic part') + ! + ! store the bookkeeping information about the contr. basis set + ! + call PTstore_icontr_cnu(PT%Maxcontracts,ioHandler,job%IOkinet_action) endif ! ! maximal size of the primitive matrix in all classes @@ -16494,18 +16469,7 @@ subroutine PTcontracted_matelem_class(jrot) ! if (trim(job%IOkinet_action)=='SAVE'.and..not.job%IOmatelem_split) then ! - if (trim(job%kinetmat_format).eq.'MPIIO') then -#ifdef TROVE_USE_MPI_ - if(mpi_rank.eq.0) then - !call MPI_File_seek(chkptMPIIO, mpioffset, MPI_SEEK_END) - call MPI_File_write_shared(chkptMPIIO,'g_rot',5,mpi_character,mpi_status_ignore,ierr) - !else - ! call MPI_File_write_shared(chkptMPIIO,'',0,mpi_character,mpi_status_ignore,ierr) - endif -#endif - else - call ioHandler%write('g_rot') - endif + call ioHandler%write('g_rot') ! endif ! @@ -16568,11 +16532,7 @@ subroutine PTcontracted_matelem_class(jrot) ! ! store the matrix elements ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - call co_write_matrix_distr(grot_t,mdimen, startdim, enddim,chkptMPIIO) - else - call ioHandler%write(grot_t) - endif + call ioHandler%write(grot_t, mdimen) ! endif endif @@ -16692,11 +16652,7 @@ subroutine PTcontracted_matelem_class(jrot) ! ! store the matrix elements ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - call co_write_matrix_distr(gcor_t,mdimen, startdim, enddim,chkptMPIIO) - else - call ioHandler%write(gcor_t) - endif + call ioHandler%write(gcor_t, mdimen) ! endif endif @@ -16774,7 +16730,7 @@ subroutine PTcontracted_matelem_class(jrot) do k1 = 1,3 do k2 = 1,3 ! - call ioHandler%write(grot_(k1,k2,:,:)) + call ioHandler%write(grot_(k1,k2,:,:), mdimen_) ! enddo enddo @@ -16786,7 +16742,7 @@ subroutine PTcontracted_matelem_class(jrot) do k1 = 1,PT%Nmodes do k2 = 1,3 ! - call ioHandler%write(gcor_(k1,k2,:,:)) + call ioHandler%write(gcor_(k1,k2,:,:), mdimen_) ! enddo enddo @@ -17098,20 +17054,8 @@ subroutine PTcontracted_matelem_class(jrot) (.not.job%IOmatelem_divide.or.job%iswap(1)==0) .and. & (.not.job%IOmatelem_split.or.job%iswap(1)==0)) then ! - if (trim(job%kinetmat_format).eq.'MPIIO') then -#ifdef TROVE_USE_MPI_ - if(mpi_rank.eq.0) then - !call MPI_File_seek(chkptMPIIO, mpioffset, MPI_SEEK_END) - call MPI_File_write_shared(chkptMPIIO,'hvib',4,mpi_character,mpi_status_ignore,ierr) - !else - ! call MPI_File_write_shared(chkptMPIIO,'',0,mpi_character,mpi_status_ignore,ierr) - endif - call co_write_matrix_distr(hvib%me,mdimen, startdim, enddim,chkptMPIIO) -#endif - else - call ioHandler%write('hvib') - call ioHandler%write(hvib%me) - endif + call ioHandler%write('hvib') + call ioHandler%write(hvib%me, mdimen) ! endif ! @@ -17123,19 +17067,8 @@ subroutine PTcontracted_matelem_class(jrot) (.not.job%IOmatelem_divide.or.job%iswap(1)==0 ).and. & (.not.job%IOmatelem_split.or.job%iswap(1)==0 ) ) then ! - if (trim(job%kinetmat_format).eq.'MPIIO') then -#ifdef TROVE_USE_MPI_ - call mpi_barrier(mpi_comm_world, ierr) - call MPI_File_seek_shared(chkptMPIIO, mpioffset, MPI_SEEK_END) - if(mpi_rank.eq.0) then - call MPI_File_write_shared(chkptMPIIO,'End Kinetic part',16,mpi_character,mpi_status_ignore,ierr) - endif - call MPI_File_close(chkptMPIIO, ierr) -#endif - else - call ioHandler%write('End Kinetic part') - deallocate(ioHandler) - endif + call ioHandler%write('End Kinetic part') + deallocate(ioHandler) ! endif ! @@ -17995,7 +17928,8 @@ subroutine PTcontracted_matelem_class_fast_II(jrot) ! ! store the bookkeeping information about the contr. basis set ! - call PTstore_icontr_cnu(PT%Maxcontracts,chkptIO,job%IOkinet_action) + ! TODO change this to ioHandler + !call PTstore_icontr_cnu(PT%Maxcontracts,ioHandler,job%IOkinet_action) ! if (job%vib_rot_contr) then write(chkptIO) 'vib-rot' @@ -34957,10 +34891,10 @@ subroutine matvec_sym(n,bterm,h,z,w) return end subroutine matvec_sym + subroutine PTstore_icontr_cnu(Maxcontracts,ioHandler,dir) - subroutine PTstore_icontr_cnu(Maxcontracts,iunit,dir) - - integer(ik),intent(in) :: Maxcontracts,iunit + integer(ik),intent(in) :: Maxcontracts + class(ioHandlerBase), intent(in) :: ioHandler character(len=18),intent(in) :: dir integer(ik) :: alloc character(len=18) :: buf18 @@ -34970,20 +34904,19 @@ subroutine PTstore_icontr_cnu(Maxcontracts,iunit,dir) selectcase (trim(dir)) ! case ('SAVE') - ! - write(iunit) Maxcontracts - ! - write(iunit) 'icontr_cnu' - ! - write(iunit) PT%icontr_cnu(0:PT%Nclasses,1:Maxcontracts) - ! - write(iunit) 'icontr_ideg' - ! - write(iunit) PT%icontr_ideg(0:PT%Nclasses,1:Maxcontracts) - ! + + call ioHandler%write(Maxcontracts) + call ioHandler%write('icontr_cnu') + call ioHandler%write(PT%icontr_cnu(0:PT%Nclasses,1:Maxcontracts)) + call ioHandler%write('icontr_ideg') + call ioHandler%write(PT%icontr_ideg(0:PT%Nclasses,1:Maxcontracts)) + case ('APPEND') ! - read(iunit) ncontr +#ifdef TROVE_USE_MPI_ + stop "APPEND in PTstore_icontr_cnu currently unsupported using MPI" +#endif + call ioHandler%read(ncontr) ! if (Maxcontracts/=ncontr) then write (out,"(' Vib. kinetic checkpoint file ',a)") job%kinetmat_file @@ -34994,21 +34927,21 @@ subroutine PTstore_icontr_cnu(Maxcontracts,iunit,dir) allocate (imat_t(0:PT%Nclasses,ncontr),stat=alloc) call ArrayStart('mat_t',alloc,size(imat_t),kind(imat_t)) ! - read(iunit) buf18(1:10) + call ioHandler%read(buf18(1:10)) if (buf18(1:10)/='icontr_cnu') then write (out,"(' Vib. kinetic checkpoint file ',a,': icontr_cnu is missing ',a)") job%kinetmat_file,buf18(1:10) stop 'PTrestore_rot_kinetic_matrix_elements - in file - icontr_cnu missing' end if ! - read(iunit) imat_t(0:PT%Nclasses,1:ncontr) + call ioHandler%read(imat_t(0:PT%Nclasses,1:ncontr)) ! - read(iunit) buf18(1:11) + call ioHandler%read(buf18(1:11)) if (buf18(1:11)/='icontr_ideg') then write (out,"(' Vib. kinetic checkpoint file ',a,': icontr_ideg is missing ',a)") job%kinetmat_file,buf18(1:11) stop 'PTrestore_rot_kinetic_matrix_elements - in file - icontr_ideg missing' end if ! - read(iunit) imat_t(0:PT%Nclasses,1:ncontr) + call ioHandler%read(imat_t(0:PT%Nclasses,1:ncontr)) ! deallocate(imat_t) ! @@ -35016,96 +34949,6 @@ subroutine PTstore_icontr_cnu(Maxcontracts,iunit,dir) ! end subroutine PTstore_icontr_cnu - subroutine PTstore_icontr_cnu_new(Maxcontracts,ioHandler,dir) - - integer(ik),intent(in) :: Maxcontracts - class(ioHandlerBase), intent(in) :: ioHandler - character(len=18),intent(in) :: dir - integer(ik) :: alloc - character(len=18) :: buf18 - integer(ik) :: ncontr - integer(ik),allocatable :: imat_t(:,:) - ! - selectcase (trim(dir)) - ! - case ('SAVE') - - call ioHandler%write(Maxcontracts) - call ioHandler%write('icontr_cnu') - call ioHandler%write(PT%icontr_cnu(0:PT%Nclasses,1:Maxcontracts)) - call ioHandler%write('icontr_ideg') - call ioHandler%write(PT%icontr_ideg(0:PT%Nclasses,1:Maxcontracts)) - - case ('APPEND') - ! - stop "APPEND in PTstore_icontr_cnu currently unsupported" - !read(iunit) ncontr - !! - !if (Maxcontracts/=ncontr) then - !write (out,"(' Vib. kinetic checkpoint file ',a)") job%kinetmat_file - !write (out,"(' Actual and stored basis sizes at J=0 do not agree ',2i8)") PT%Maxcontracts,ncontr - !stop 'PTrestore_rot_kinetic_matrix_elements - in file - illegal nroots ' - !end if - !! - !allocate (imat_t(0:PT%Nclasses,ncontr),stat=alloc) - !call ArrayStart('mat_t',alloc,size(imat_t),kind(imat_t)) - !! - !read(iunit) buf18(1:10) - !if (buf18(1:10)/='icontr_cnu') then - !write (out,"(' Vib. kinetic checkpoint file ',a,': icontr_cnu is missing ',a)") job%kinetmat_file,buf18(1:10) - !stop 'PTrestore_rot_kinetic_matrix_elements - in file - icontr_cnu missing' - !end if - !! - !read(iunit) imat_t(0:PT%Nclasses,1:ncontr) - !! - !read(iunit) buf18(1:11) - !if (buf18(1:11)/='icontr_ideg') then - !write (out,"(' Vib. kinetic checkpoint file ',a,': icontr_ideg is missing ',a)") job%kinetmat_file,buf18(1:11) - !stop 'PTrestore_rot_kinetic_matrix_elements - in file - icontr_ideg missing' - !end if - !! - !read(iunit) imat_t(0:PT%Nclasses,1:ncontr) - !! - !deallocate(imat_t) - ! - end select - ! - end subroutine PTstore_icontr_cnu_new - - subroutine PTstoreMPI_icontr_cnu(maxcontracts,iunit,dir) - use mpi_aux - - integer(ik),intent(in) :: maxcontracts - type(mpi_file),intent(in) :: iunit - character(len=18),intent(in) :: dir - integer(ik) :: alloc - character(len=18) :: buf18 - integer(ik) :: ncontr - integer(ik),allocatable :: imat_t(:,:) - integer::ierr - ! - select case(trim(dir)) - ! - case ('SAVE') - ! -#ifdef TROVE_USE_MPI_ - call mpi_file_write(iunit, maxcontracts, 1,mpi_integer,mpi_status_ignore,ierr) - ! - call mpi_file_write(iunit, 'icontr_cnu', 10,mpi_character,mpi_status_ignore,ierr) - ! - call mpi_file_write(iunit, pt%icontr_cnu(0:pt%nclasses,1:maxcontracts), (1+pt%nclasses)*maxcontracts, mpi_integer, & - mpi_status_ignore, ierr) - ! - call mpi_file_write(iunit, 'icontr_ideg', 11,mpi_character,mpi_status_ignore,ierr) - ! - call mpi_file_write(iunit, pt%icontr_ideg(0:pt%nclasses,1:maxcontracts), (1+pt%nclasses)*maxcontracts, mpi_integer, & - mpi_status_ignore, ierr) - -#endif - end select - - end subroutine PTstorempi_icontr_cnu - subroutine PTdefine_contr_from_eigenvect(nroots,Neigenlevels,eigen) @@ -38501,7 +38344,8 @@ subroutine PTcontracted_matelem_class_fast(jrot) ! ! store the bookkeeping information about the contr. basis set ! - call PTstore_icontr_cnu(PT%Maxcontracts,chkptIO,job%IOkinet_action) + ! TODO change me to ioHandler + !call PTstore_icontr_cnu(PT%Maxcontracts,ioHandler,job%IOkinet_action) ! if (job%vib_rot_contr) then write(chkptIO) 'vib-rot' diff --git a/tran.f90 b/tran.f90 index ee92b9b..54124ed 100644 --- a/tran.f90 +++ b/tran.f90 @@ -14,7 +14,9 @@ module tran use moltype, only : manifold,intensity,extF use symmetry, only : sym - use perturbation, only : PTintcoeffsT,PTrotquantaT,PTNclasses,PTstore_icontr_cnu,PTeigenT,PTdefine_contr_from_eigenvect,PTrepresT,PTstorempi_icontr_cnu + use perturbation, only : PTintcoeffsT,PTrotquantaT,PTNclasses,PTstore_icontr_cnu,PTeigenT,PTdefine_contr_from_eigenvect,PTrepresT + use io_handler_base + use io_handler_ftn private public read_contrind,read_eigenval, TReigenvec_unit, bset_contrT, & @@ -1615,7 +1617,8 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! treat_vibration = .false. ! - call PTstorempi_icontr_cnu(Neigenroots,fileh_w,job%IOj0matel_action) + ! TODO replace with ioHandler (maybe, probably just delete) + !call PTstorempi_icontr_cnu(Neigenroots,fileh_w,job%IOj0matel_action) ! if (job%vib_rot_contr) then call MPI_File_write(fileh_w, 'vib-rot', 7, mpi_character, mpi_status_ignore, ierr) @@ -1634,7 +1637,8 @@ subroutine TRconvert_matel_j0_eigen(jrot) treat_vibration = .false. if(mpi_rank .eq. 0) then ! - call PTstore_icontr_cnu(Neigenroots,chkptIO,job%IOj0matel_action) + ! TODO replace with ioHandler + !call PTstore_icontr_cnu(Neigenroots,ioHandler,job%IOj0matel_action) ! if (job%vib_rot_contr) then write(chkptIO) 'vib-rot' From d8bdac1bdcc90f9c1af69868e6995bf53cc63828 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Mon, 5 Jul 2021 18:36:58 +0100 Subject: [PATCH 33/40] Fix bug in MPI array writer and only enable MPI writer when compiling with MPI --- io_handler_mpi.f90 | 4 ++-- perturbation.f90 | 13 +++++++++++-- 2 files changed, 13 insertions(+), 4 deletions(-) diff --git a/io_handler_mpi.f90 b/io_handler_mpi.f90 index 7db62aa..41fc3f4 100644 --- a/io_handler_mpi.f90 +++ b/io_handler_mpi.f90 @@ -205,11 +205,11 @@ subroutine write2DArrayMPI(this, object) return end if - call MPI_File_write(this%fileh, byteSize, 1, MPI_INTEGER, & + call MPI_File_write(this%fileh, arrSizeBytes, 1, MPI_INTEGER, & MPI_STATUS_IGNORE, ierr) call MPI_File_write(this%fileh, object, globalSize, mpiType, & MPI_STATUS_IGNORE, ierr) - call MPI_File_write(this%fileh, byteSize, 1, MPI_INTEGER, & + call MPI_File_write(this%fileh, arrSizeBytes, 1, MPI_INTEGER, & MPI_STATUS_IGNORE, ierr) end subroutine diff --git a/perturbation.f90 b/perturbation.f90 index 2c07eab..751fa24 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -16284,8 +16284,17 @@ subroutine PTcontracted_matelem_class(jrot) job_is ='Vib. matrix elements of the rot. kinetic part' call IOStart(trim(job_is),chkptIO) ! - allocate(ioHandler, source=ioHandlerFTN(job%kinetmat_file, err, action='write', position='rewind', status='replace', form='unformatted')) - !allocate(ioHandler, source=ioHandlerMPI(job%kinetmat_file, err, action='write', position='rewind', status='replace', form='unformatted')) +#ifdef TROVE_USE_MPI_ + allocate(ioHandler, & + source=ioHandlerMPI(& + job%kinetmat_file, err, & + action='write', position='rewind', status='replace', form='unformatted')) +#else + allocate(ioHandler, & + source=ioHandlerFTN(& + job%kinetmat_file, err, & + action='write', position='rewind', status='replace', form='unformatted')) +#endif HANDLE_ERROR(err) call ioHandler%write('Start Kinetic part') From 34150942d8689f156e4d91fed6f9085cdd0f43e2 Mon Sep 17 00:00:00 2001 From: ageorgou <1186102+ageorgou@users.noreply.github.com> Date: Wed, 18 Aug 2021 18:10:31 +0100 Subject: [PATCH 34/40] Small changes to unit test build (#37) * Fixes for build * Don't take size of unspecified-length string (Intel error) * Avoid polymorphism problems with Intel compiler To use an unlimited-polymorphic value as argument in a subroutine, the corresponding dummy argument must also be declared as unlimited polymorphic. This isn't the case with the MPI_File_Write routines, so we have to explicitly check the type each time. The gfortran compiler is happy to ignore this (or perhaps it looks up the right subroutine to use automatically) - this error only appears with the Intel compiler. * Pass in libraries from main Makefile for all compilers The LAPACK variable is only used if we're building with MPI, which requires having built TROVE first anyway. So this doesn't stop us from testing the serial ioHandler. * Use concrete types so tests pass with Intel At this point, the MPI tests pass when using 2 or 4 processes. The second test (writing a column-distributed array) fails when using only 1 process only due to a dimension mismatch between read and write (which is maybe to be expected, as I don't think that code is called in TROVE when comm_size is 1). * Use ioHandler in more matelem variants * Write j0_matelem with new handler * Set up pFUnit on CI * Use the right compiler for unit tests * Allow GitHub Actions to get submodule Maybe it doesn't have an SSH key? * Only test MPI I/O handler when building with MPI Leave this out for CI purposes for now, it will be simpler to re-enable when we include the other CI changes. * Avoid cluttering test output with pFUnit build Might also make it easier to cache built library in the future. * Separate MPI unit tests for easier control * Remove unnecessary checks We are only including this file when using MPI anyway. This way may also catch errors earlier if we accidentally try to compile it. * Exclude io_handler_mpi completely unless using MPI --- .github/workflows/ci.yml | 5 +- .gitmodules | 2 +- io_handler_mpi.f90 | 32 +++++++-- makefile | 33 ++++++--- perturbation.f90 | 69 +++++++++++-------- test/unit/makefile | 7 +- tran.f90 | 145 +++++++++++---------------------------- 7 files changed, 134 insertions(+), 159 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 2a80e67..e6faad8 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -40,10 +40,13 @@ jobs: - name: Install Intel MKL run: sudo apt-get install -y intel-mkl + - name: Build pFUnit + run: make COMPILER=gfortran install-pfunit + - name: Build run: | gfortran --version make COMPILER=gfortran MODE=ci - name: Test - run: make test + run: make COMPILER=gfortran test diff --git a/.gitmodules b/.gitmodules index 19d94f0..43ec5aa 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,3 +1,3 @@ [submodule "lib/pFUnit"] path = lib/pFUnit - url = git@github.com:Goddard-Fortran-Ecosystem/pFUnit.git + url = https://github.com/Goddard-Fortran-Ecosystem/pFUnit.git diff --git a/io_handler_mpi.f90 b/io_handler_mpi.f90 index 41fc3f4..4d12362 100644 --- a/io_handler_mpi.f90 +++ b/io_handler_mpi.f90 @@ -1,10 +1,32 @@ #include "errors.fpp" +#define MPI_WRAPPER(function, handle, obj, size, mytype, status, err) \ +select type(obj); \ + type is (integer(ik)); \ + call function(handle, obj, size, mytype, status, err); \ + type is (integer(hik)); \ + call function(handle, obj, size, mytype, status, err); \ + type is (real); \ + call function(handle, obj, size, mytype, status, err); \ + type is (real(rk)); \ + call function(handle, obj, size, mytype, status, err); \ + type is (real(ark)); \ + call function(handle, obj, size, mytype, status, err); \ + type is (complex); \ + call function(handle, obj, size, mytype, status, err); \ + type is (character(len=*)); \ + call function(handle, obj, size, mytype, status, err); \ + class default; \ + write(*,*) 'Not covered'; \ +end select + + module io_handler_mpi use mpi_f08 use mpi_aux use io_handler_base use errors + use accuracy, only : rk, ark, ik, hik implicit none @@ -143,7 +165,7 @@ subroutine getMPIVarInfo(object, byteSize, mpiType) byteSize = sizeof(object) mpiType = MPI_DOUBLE_COMPLEX type is (character(len=*)) - byteSize = sizeof(object) + byteSize = len(object) * sizeof('a') mpiType = MPI_CHARACTER class default print *, "ERROR: Unknown type" @@ -173,7 +195,7 @@ subroutine writeScalarMPI(this, object) call MPI_File_write(this%fileh, byteSize, 1, MPI_INTEGER, & MPI_STATUS_IGNORE, ierr) - call MPI_File_write(this%fileh, object, length, mpiType, & + MPI_WRAPPER(MPI_File_write, this%fileh, object, length, mpiType, & MPI_STATUS_IGNORE, ierr) call MPI_File_write(this%fileh, byteSize, 1, MPI_INTEGER, & MPI_STATUS_IGNORE, ierr) @@ -207,7 +229,7 @@ subroutine write2DArrayMPI(this, object) call MPI_File_write(this%fileh, arrSizeBytes, 1, MPI_INTEGER, & MPI_STATUS_IGNORE, ierr) - call MPI_File_write(this%fileh, object, globalSize, mpiType, & + MPI_WRAPPER(MPI_File_write, this%fileh, object, globalSize, mpiType, & MPI_STATUS_IGNORE, ierr) call MPI_File_write(this%fileh, arrSizeBytes, 1, MPI_INTEGER, & MPI_STATUS_IGNORE, ierr) @@ -245,7 +267,7 @@ subroutine write2DArrayDistBlacsMPI(this, object, descr, block_type) call MPI_File_set_view(this%fileh, this%offset, mpiType, block_type, & 'native', MPI_INFO_NULL, ierr) ! Write array in parallel - call MPI_File_write_all(this%fileh, object, size(object), mpiType, & + MPI_WRAPPER(MPI_File_write_all, this%fileh, object, size(object), mpiType, & MPI_STATUS_IGNORE, ierr) ! Offset by size of array and end bookend integer this%offset = this%offset + arrSizeBytes + 4 @@ -282,7 +304,7 @@ subroutine write2DArrayDistColumnMPI(this, object, mdimen) ! Seek to byte after bookend call MPI_File_seek_shared(this%fileh, this%offset, MPI_SEEK_SET, ierr) ! Write array in parallel - call MPI_File_write_ordered(this%fileh,object,1,mpitype_column,MPI_STATUS_IGNORE,ierr) + MPI_WRAPPER(MPI_File_write_ordered,this%fileh,object,1,mpitype_column,MPI_STATUS_IGNORE,ierr) ! Offset by size of array and end bookend integer this%offset = this%offset + arrSizeBytes + 4 ! Ensure all file pointers point to end of array diff --git a/makefile b/makefile index aae3620..e9c665f 100644 --- a/makefile +++ b/makefile @@ -88,6 +88,11 @@ OBJDIR=. user_pot_dir=. TARGET=$(BINDIR)/$(EXE) +MPI_SRCS = +ifdef USE_MPI + MPI_SRCS += io_handler_mpi.f90 +endif + SRCS := timer.f90 accuracy.f90 diag.f90 dipole.f90 extfield.f90 fields.f90 fwigxjpf.f90 input.f90 kin_xy2.f90 lapack.f90 \ me_bnd.f90 me_numer.f90 me_rot.f90 me_str.f90 \ mol_abcd.f90 mol_c2h4.f90 mol_c2h6.f90 mol_c3h6.f90 mol_ch3oh.f90 mol_xy.f90 \ @@ -97,11 +102,10 @@ SRCS := timer.f90 accuracy.f90 diag.f90 dipole.f90 extfield.f90 fields.f90 fwigx pot_xy2.f90 pot_xy3.f90 pot_xy4.f90 pot_zxy2.f90 pot_zxy3.f90 \ prop_xy2.f90 prop_xy2_quad.f90 prop_xy2_spinrot.f90 prop_xy2_spinspin.f90 \ io_handler_base.f90 io_handler_ftn.f90 \ - refinement.f90 richmol_data.f90 rotme_cart_tens.f90 symmetry.f90 tran.f90 trove.f90 $(pot_user).f90 -ifdef USE_MPI - SRCS += io_handler_mpi.f90 -endif + refinement.f90 richmol_data.f90 rotme_cart_tens.f90 symmetry.f90 tran.f90 trove.f90 $(pot_user).f90 $(MPI_SRCS) + OBJS := ${SRCS:.f90=.o} +MPI_OBJS := ${MPI_SRCS:.f90=.o} VPATH = $(SRCDIR):$(user_pot_dir):$(OBJDIR) @@ -133,7 +137,7 @@ ifneq ($(BINDIR),.) endif install-pfunit: - git submodule init # Make sure we have pfunit + git submodule update --init # Make sure we have pfunit mkdir $(PFUNIT_DIR)/build cd $(PFUNIT_DIR)/build; cmake .. $(MAKE) -C $(PFUNIT_DIR)/build @@ -152,17 +156,26 @@ tarball: checkin: ci -l Makefile *.f90 -test: regression-tests unit-tests +test: regression-tests unit-tests-nompi unit-tests-mpi regression-tests: $(TARGET) echo "Running regression tests" cd test/regression; ./run_regression_tests.sh -unit-tests: $(TARGET) - $(MAKE) -C test/unit test_io test_mpi_io - echo "Running unit tests" +unit-tests-nompi: $(TARGET) + $(MAKE) -C test/unit LAPACK="$(LAPACK)" test_io + echo "Running unit tests without MPI" test/unit/test_io + +ifdef USE_MPI +unit-tests-mpi: $(TARGET) + $(MAKE) -C test/unit LAPACK="$(LAPACK)" test_mpi_io + echo "Running unit tests with MPI" mpirun -n 4 --mca opal_warn_on_missing_libcuda 0 test/unit/test_mpi_io +else +unit-tests-mpi: $(TARGET) + echo "Skipping unit tests with MPI (USE_MPI not set)" +endif ################################################################################ ## DEPENDENCIES @@ -202,7 +215,7 @@ mol_xy.o: mol_xy.f90 accuracy.o moltype.o mol_zxy2.o: mol_zxy2.f90 accuracy.o moltype.o mol_zxy3.o: mol_zxy3.f90 accuracy.o moltype.o lapack.o mpi_aux.o: mpi_aux.f90 accuracy.o timer.o -perturbation.o: perturbation.f90 accuracy.o molecules.o moltype.o lapack.o plasma.o fields.o timer.o symmetry.o me_numer.o diag.o mpi_aux.o +perturbation.o: perturbation.f90 accuracy.o molecules.o moltype.o lapack.o plasma.o fields.o timer.o symmetry.o me_numer.o diag.o mpi_aux.o io_handler_base.o io_handler_ftn.o $(MPI_OBJS) plasma.o: plasma.f90 accuracy.o timer.o pot_abcd.o: pot_abcd.f90 accuracy.o moltype.o lapack.o pot_c2h4.o: pot_c2h4.f90 accuracy.o moltype.o diff --git a/perturbation.f90 b/perturbation.f90 index 751fa24..fb62edf 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -17824,6 +17824,9 @@ subroutine PTcontracted_matelem_class_fast_II(jrot) integer(ik) :: Nsym,isym,Nsymi,Nsymj,jsymcoeff,Ntot integer(ik), allocatable :: isymcoeff_vs_isym(:,:) double precision,parameter :: a0 = -0.5d0 + + class(ioHandlerBase), allocatable :: ioHandler + type(ErrorType) :: err ! call TimerStart('Contracted matelements-class-fast') ! @@ -17932,16 +17935,19 @@ subroutine PTcontracted_matelem_class_fast_II(jrot) job_is ='Vib. matrix elements of the rot. kinetic part' call IOStart(trim(job_is),chkptIO) - open(chkptIO,form='unformatted',action='write',position='rewind',status='replace',file=job%kinetmat_file) - write(chkptIO) 'Start Kinetic part' + allocate(ioHandler, & + source=ioHandlerFTN(& + job%kinetmat_file, err, & + action='write', position='rewind', status='replace', form='unformatted')) + HANDLE_ERROR(err) + call ioHandler%write('Start Kinetic part') ! ! store the bookkeeping information about the contr. basis set ! - ! TODO change this to ioHandler - !call PTstore_icontr_cnu(PT%Maxcontracts,ioHandler,job%IOkinet_action) + call PTstore_icontr_cnu(PT%Maxcontracts,ioHandler,job%IOkinet_action) ! if (job%vib_rot_contr) then - write(chkptIO) 'vib-rot' + call ioHandler%write('vib-rot') endif ! endif @@ -18053,7 +18059,7 @@ subroutine PTcontracted_matelem_class_fast_II(jrot) ! if (trim(job%IOkinet_action)=='SAVE'.and..not.job%IOmatelem_split) then ! - write(chkptIO) 'g_rot' + call ioHandler%write('g_rot') ! endif ! @@ -18133,7 +18139,7 @@ subroutine PTcontracted_matelem_class_fast_II(jrot) if (job%IOmatelem_split) then write(chkptIO_) grot_t else - write(chkptIO) grot_t + call ioHandler%write(grot_t, mdimen) endif ! endif @@ -18157,7 +18163,7 @@ subroutine PTcontracted_matelem_class_fast_II(jrot) ! if (trim(job%IOkinet_action)=='SAVE'.and..not.job%IOmatelem_split) then ! - write(chkptIO) 'g_cor' + call ioHandler%write('g_cor') ! endif ! @@ -18308,7 +18314,7 @@ subroutine PTcontracted_matelem_class_fast_II(jrot) if (job%IOmatelem_split) then write(chkptIO_) grot_t else - write(chkptIO) grot_t + call ioHandler%write(grot_t, mdimen) endif ! endif @@ -18353,7 +18359,7 @@ subroutine PTcontracted_matelem_class_fast_II(jrot) if ((trim(job%IOkinet_action)=='SAVE'.or.trim(job%IOkinet_action)=='VIB_SAVE').and. & (.not.job%IOmatelem_split.or.job%iswap(1)==0.or.job%iswap(1)==(PT%Nmodes+3)*3 ) ) then ! - write(chkptIO) 'hvib' + call ioHandler%write('hvib') ! endif ! @@ -18563,10 +18569,8 @@ subroutine PTcontracted_matelem_class_fast_II(jrot) enddo !$omp end parallel do ! - !write(chkptIO) hvib_t - ! if (trim(job%IOkinet_action)=='SAVE') then - write(chkptIO) hvib_t + call ioHandler%write(hvib_t) endif ! endif @@ -18603,8 +18607,8 @@ subroutine PTcontracted_matelem_class_fast_II(jrot) if ((trim(job%IOkinet_action)=='SAVE'.or.trim(job%IOkinet_action)=='VIB_SAVE').and.& (.not.job%IOmatelem_split.or.job%iswap(1)==0 )) then ! - write(chkptIO) 'End Kinetic part' - close(chkptIO,status='keep') + call ioHandler%write('End Kinetic part') + deallocate(ioHandler) ! endif ! @@ -38246,6 +38250,9 @@ subroutine PTcontracted_matelem_class_fast(jrot) type(me_type), allocatable :: vpot_me(:) type(me_type), allocatable :: pseudo_me(:) type(me_type), allocatable :: extF_me(:) + + class(ioHandlerBase), allocatable :: ioHandler + type(ErrorType) :: err ! call TimerStart('Contracted matelements-class-fast') ! @@ -38348,16 +38355,20 @@ subroutine PTcontracted_matelem_class_fast(jrot) job_is ='Vib. matrix elements of the rot. kinetic part' call IOStart(trim(job_is),chkptIO) ! - open(chkptIO,form='unformatted',action='write',position='rewind',status='replace',file=job%kinetmat_file) - write(chkptIO) 'Start Kinetic part' + allocate(ioHandler, & + source=ioHandlerFTN(& + job%kinetmat_file, err, & + action='write', position='rewind', status='replace', form='unformatted')) + HANDLE_ERROR(err) + + call ioHandler%write('Start Kinetic part') ! ! store the bookkeeping information about the contr. basis set ! - ! TODO change me to ioHandler - !call PTstore_icontr_cnu(PT%Maxcontracts,ioHandler,job%IOkinet_action) + call PTstore_icontr_cnu(PT%Maxcontracts,ioHandler,job%IOkinet_action) ! if (job%vib_rot_contr) then - write(chkptIO) 'vib-rot' + call ioHandler%write('vib-rot') endif ! endif @@ -38430,7 +38441,7 @@ subroutine PTcontracted_matelem_class_fast(jrot) ! if (trim(job%IOkinet_action)=='SAVE'.and..not.job%IOmatelem_split) then ! - write(chkptIO) 'g_rot' + call ioHandler%write('g_rot') ! endif ! @@ -38504,7 +38515,7 @@ subroutine PTcontracted_matelem_class_fast(jrot) if (job%IOmatelem_split) then write(chkptIO_) grot_t else - write(chkptIO) grot_t + call ioHandler%write(grot_t, mdimen) endif ! endif @@ -38528,7 +38539,7 @@ subroutine PTcontracted_matelem_class_fast(jrot) ! if (trim(job%IOkinet_action)=='SAVE'.and..not.job%IOmatelem_split) then ! - write(chkptIO) 'g_cor' + call ioHandler%write('g_cor') ! endif ! @@ -38645,7 +38656,7 @@ subroutine PTcontracted_matelem_class_fast(jrot) if (job%IOmatelem_split) then write(chkptIO_) grot_t else - write(chkptIO) grot_t + call ioHandler%write(grot_t, mdimen) endif ! endif @@ -38690,7 +38701,7 @@ subroutine PTcontracted_matelem_class_fast(jrot) if ((trim(job%IOkinet_action)=='SAVE'.or.trim(job%IOkinet_action)=='VIB_SAVE').and. & (.not.job%IOmatelem_split.or.job%iswap(1)==0.or.job%iswap(1)==(PT%Nmodes+3)*3 ) ) then ! - write(chkptIO) 'hvib' + call ioHandler%write('hivb') ! endif ! @@ -38825,10 +38836,8 @@ subroutine PTcontracted_matelem_class_fast(jrot) enddo !$omp end parallel do ! - !write(chkptIO) hvib_t - ! if (trim(job%IOkinet_action)=='SAVE') then - write(chkptIO) hvib_t + call ioHandler%write(hvib_t, mdimen) endif ! endif @@ -38865,8 +38874,8 @@ subroutine PTcontracted_matelem_class_fast(jrot) if ((trim(job%IOkinet_action)=='SAVE'.or.trim(job%IOkinet_action)=='VIB_SAVE').and.& (.not.job%IOmatelem_split.or.job%iswap(1)==0 )) then ! - write(chkptIO) 'End Kinetic part' - close(chkptIO,status='keep') + call ioHandler%write('End Kinetic part') + deallocate(ioHandler) ! endif ! diff --git a/test/unit/makefile b/test/unit/makefile index 6554ac2..7b2769c 100644 --- a/test/unit/makefile +++ b/test/unit/makefile @@ -8,11 +8,6 @@ include $(BASE_DIR)/lib/pFUnit/build/PFUNIT.mk FFLAGS += $(PFUNIT_EXTRA_FFLAGS) FFLAGS += -I../.. -LAPACK = -L${MKLROOT}/lib/intel64 -Wl,--no-as-needed -lmkl_gf_lp64 -lmkl_gnu_thread -lmkl_core -lgomp -lpthread -lm -ldl -ifdef USE_MPI -LAPACK += -lmkl_blacs_openmpi_lp64 -lmkl_scalapack_lp64 -endif - test_io_TESTS := test_io.pf test_io_OTHER_SRCS := $(addprefix $(BASE_DIR)/, io_handler_ftn.f90 io_handler_base.f90 ) $(eval $(call make_pfunit_test,test_io)) @@ -20,7 +15,7 @@ $(eval $(call make_pfunit_test,test_io)) ifdef USE_MPI FFLAGS += -DTROVE_USE_MPI_ test_mpi_io_TESTS := test_mpi_io.pf -test_mpi_io_OTHER_LIBRARIES := ${LAPACK} +test_mpi_io_OTHER_LIBRARIES := ${LAPACK} # passed in from base makefile test_mpi_io_OTHER_SRCS := $(addprefix $(BASE_DIR)/, io_handler_mpi.f90 io_handler_base.f90 mpi_aux.f90 timer.f90 accuracy.f90) $(eval $(call make_pfunit_test,test_mpi_io)) endif diff --git a/tran.f90 b/tran.f90 index 54124ed..8070cbc 100644 --- a/tran.f90 +++ b/tran.f90 @@ -2,6 +2,8 @@ ! defines different transformations of the eigenvectors given ! in terms of the contracted basis state representaion. ! +#include "errors.fpp" + module tran ! set tran_debug > 2 with small vibrational bases and small expansions only !#define tran_debug 1 @@ -17,6 +19,10 @@ module tran use perturbation, only : PTintcoeffsT,PTrotquantaT,PTNclasses,PTstore_icontr_cnu,PTeigenT,PTdefine_contr_from_eigenvect,PTrepresT use io_handler_base use io_handler_ftn +#ifdef TROVE_USE_MPI_ + use io_handler_mpi +#endif + use errors private public read_contrind,read_eigenval, TReigenvec_unit, bset_contrT, & @@ -1320,6 +1326,8 @@ subroutine TRconvert_matel_j0_eigen(jrot) type(MPI_File) :: fileh, fileh_w integer(kind=MPI_OFFSET_KIND) :: mpioffset,read_offset,write_offset integer :: ierr + class(ioHandlerBase), allocatable :: ioHandler + type(ErrorType) :: err type(MPI_Datatype) :: gmat_block_type, psi_block_type, mat_t_block_type, mat_s_block_type, extF_block_type integer,dimension(9) :: desc_gmat, desc_mat_t, desc_mat_s, desc_psi, desc_extF @@ -1604,48 +1612,27 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! job_is ='Eigen-vib. matrix elements of the rot. kinetic part' ! - if (trim(job%kinetmat_format).eq.'MPIIO') then + call IOStart(trim(job_is),chkptIO) #ifdef TROVE_USE_MPI_ - call MPI_File_open(mpi_comm_world, job%kineteigen_file, mpi_mode_wronly+mpi_mode_create, mpi_info_null, fileh_w, ierr) - call MPI_File_set_errhandler(fileh_w, MPI_ERRORS_ARE_FATAL) - mpioffset = 0 - call MPI_File_set_size(fileh_w, mpioffset, ierr) - ! - if(mpi_rank .eq. 0) then - call MPI_File_write(fileh_w, '[MPIIO]', 7, mpi_character, mpi_status_ignore, ierr) - call MPI_File_write(fileh_w, 'Start Kinetic part', 18, mpi_character, mpi_status_ignore, ierr) - ! - treat_vibration = .false. - ! - ! TODO replace with ioHandler (maybe, probably just delete) - !call PTstorempi_icontr_cnu(Neigenroots,fileh_w,job%IOj0matel_action) - ! - if (job%vib_rot_contr) then - call MPI_File_write(fileh_w, 'vib-rot', 7, mpi_character, mpi_status_ignore, ierr) - endif - else - mpioffset = 0 - treat_vibration = .false. - endif + allocate(ioHandler, & + source=ioHandlerMPI(& + job%kineteigen_file, err, & + action='write', position='rewind', status='replace', form='unformatted')) +#else + allocate(ioHandler, & + source=ioHandlerFTN(& + job%kineteigen_file, err, & + action='write', position='rewind', status='replace', form='unformatted')) #endif - else - call IOStart(trim(job_is),chkptIO) - ! - open(chkptIO,form='unformatted',action='write',position='rewind',status='replace',file=job%kineteigen_file) - write(chkptIO) 'Start Kinetic part' - ! - treat_vibration = .false. - if(mpi_rank .eq. 0) then - ! - ! TODO replace with ioHandler - !call PTstore_icontr_cnu(Neigenroots,ioHandler,job%IOj0matel_action) - ! - if (job%vib_rot_contr) then - write(chkptIO) 'vib-rot' - endif - endif + HANDLE_ERROR(err) + call ioHandler%write('Start Kinetic part') + + treat_vibration = .false. + call PTstore_icontr_cnu(Neigenroots,ioHandler,job%IOj0matel_action) + if (job%vib_rot_contr) then + call ioHandler%write('vib-rot') endif - ! + ! endif ! rootsize = int(bset_contr(1)%Maxcontracts*(bset_contr(1)%Maxcontracts+1)/2,hik) @@ -1690,19 +1677,9 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! task = 'rot' ! - if (trim(job%kinetmat_format).eq.'MPIIO') then -#ifdef TROVE_USE_MPI_ - call MPI_File_seek_shared(fileh_w, int(0,MPI_OFFSET_KIND), MPI_SEEK_END) - if(mpi_rank.eq.0) call MPI_File_write_shared(fileh_w, 'g_rot', 5, mpi_character, mpi_status_ignore, ierr) - call mpi_barrier(MPI_COMM_WORLD, ierr) - ! - call restore_rot_kinetic_matrix_elements_mpi(jrot,treat_vibration,task,fileh) -#endif - else - write(chkptIO) 'g_rot' + call ioHandler%write('g_rot') ! - call restore_rot_kinetic_matrix_elements(jrot,treat_vibration,task,iunit) - endif + call restore_rot_kinetic_matrix_elements(jrot,treat_vibration,task,iunit) ! else ! @@ -1726,10 +1703,6 @@ subroutine TRconvert_matel_j0_eigen(jrot) #ifdef TROVE_USE_MPI_ call MPI_File_get_position(fileh, read_offset, ierr) call MPI_File_set_view(fileh, read_offset, mpi_byte, gmat_block_type, "native", MPI_INFO_NULL, ierr) - - !call MPI_File_seek_shared(fileh_w, int(0,MPI_OFFSET_KIND),MPI_SEEK_END) - call MPI_File_get_position_shared(fileh_w, write_offset, ierr) - call MPI_File_set_view(fileh_w, write_offset, mpi_byte, mat_s_block_type, "native", MPI_INFO_NULL, ierr) #endif endif ! @@ -1794,13 +1767,7 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! else ! - if (trim(job%kinetmat_format).eq.'MPIIO') then -#ifdef TROVE_USE_MPI_ - call MPI_File_write_all(fileh_w, mat_s, size(mat_s), mpi_double_precision, mpi_status_ignore, ierr) -#endif - else - write (chkptIO) mat_s - endif + call ioHandler%write(mat_s, desc_mat_s, mat_s_block_type) ! endif ! @@ -1814,13 +1781,6 @@ subroutine TRconvert_matel_j0_eigen(jrot) read_offset = read_offset + 9*int(dimen,MPI_OFFSET_KIND)*dimen*mpi_real_size call MPI_File_set_view(fileh, int(0,MPI_OFFSET_KIND), mpi_byte, mpi_byte, "native", MPI_INFO_NULL, ierr) call MPI_File_seek(fileh, read_offset, MPI_SEEK_SET) - - write_offset = write_offset + 9*int(Neigenroots,MPI_OFFSET_KIND)*Neigenroots*mpi_real_size - !call MPI_File_set_view(fileh_w, write_offset, mpi_byte, mpi_byte, "native", MPI_INFO_NULL, ierr) - call MPI_File_set_view(fileh_w, int(0,MPI_OFFSET_KIND), mpi_byte, mpi_byte, "native", MPI_INFO_NULL, ierr) - call MPI_File_seek_shared(fileh_w, write_offset, MPI_SEEK_SET) - !write_offset = 0 - !call MPI_File_seek_shared(fileh_w, write_offset, MPI_SEEK_END) #endif endif @@ -1838,15 +1798,12 @@ subroutine TRconvert_matel_j0_eigen(jrot) #ifdef TROVE_USE_MPI_ call restore_rot_kinetic_matrix_elements_mpi(jrot,treat_vibration,task,fileh) ! - if(mpi_rank.eq.0) call MPI_File_write_shared(fileh_w, 'g_cor', 5, mpi_character, mpi_status_ignore, ierr) - call MPI_Barrier(MPI_COMM_WORLD, ierr) - !call MPI_File_seek_shared(fileh_w, int(0,MPI_OFFSET_KIND), MPI_SEEK_END) + call MPI_Barrier(MPI_COMM_WORLD, ierr) ! May no longer be needed? #endif else call restore_rot_kinetic_matrix_elements(jrot,treat_vibration,task,iunit) - ! - write(chkptIO) 'g_cor' endif + call ioHandler%write('g_cor') ! endif ! @@ -1860,9 +1817,6 @@ subroutine TRconvert_matel_j0_eigen(jrot) #ifdef TROVE_USE_MPI_ call MPI_File_get_position(fileh, read_offset, ierr) call MPI_File_set_view(fileh, read_offset, mpi_byte, gmat_block_type, "native", MPI_INFO_NULL, ierr) - - call MPI_File_get_position_shared(fileh_w, write_offset, ierr) - call MPI_File_set_view(fileh_w, write_offset, mpi_byte, mat_s_block_type, "native", MPI_INFO_NULL, ierr) #endif endif ! @@ -1929,13 +1883,7 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! else ! - if (trim(job%kinetmat_format).eq.'MPIIO') then -#ifdef TROVE_USE_MPI_ - call MPI_File_write_all(fileh_w, mat_s, size(mat_s), mpi_double_precision, mpi_status_ignore, ierr) -#endif - else - write (chkptIO) mat_s - endif + call ioHandler%write(mat_s, desc_mat_s, mat_s_block_type) ! endif ! @@ -1949,35 +1897,17 @@ subroutine TRconvert_matel_j0_eigen(jrot) read_offset = read_offset + 3*int(dimen,MPI_OFFSET_KIND)*dimen*mpi_real_size call MPI_File_set_view(fileh, int(0,MPI_OFFSET_KIND), mpi_byte, mpi_byte, "native", MPI_INFO_NULL, ierr) call MPI_File_seek(fileh, read_offset, MPI_SEEK_SET) - - write_offset = write_offset + 3*int(Neigenroots,MPI_OFFSET_KIND)*Neigenroots*mpi_real_size - !call MPI_File_set_view(fileh_w, write_offset, mpi_byte, mpi_byte, "native", MPI_INFO_NULL, ierr) - call MPI_File_set_view(fileh_w, int(0,MPI_OFFSET_KIND), mpi_byte, mpi_byte, "native", MPI_INFO_NULL, ierr) - call MPI_File_seek_shared(fileh_w, write_offset, MPI_SEEK_END) - !write_offset = 0 #endif endif ! if (job%verbose>=5) call TimerStop('J0-convertion for g_cor') ! if ((.not.job%IOmatelem_split.or.job%iswap(1)==1).and.(mpi_rank.eq.0)) then - if (trim(job%kinetmat_format).eq.'MPIIO') then -#ifdef TROVE_USE_MPI_ - call MPI_File_write_shared(fileh_w, 'End Kinetic part', 16, mpi_character, mpi_status_ignore, ierr) -#endif - else - write(chkptIO) 'End Kinetic part' - endif + call ioHandler%write('End Kinetic part') endif ! - if (.not.job%vib_rot_contr) then - if (trim(job%kinetmat_format).eq.'MPIIO') then -#ifdef TROVE_USE_MPI_ - call MPI_File_close(fileh_w, ierr) -#endif - else - close(chkptIO,status='keep') - endif + if (.not.job%vib_rot_contr) then + deallocate(ioHandler) endif ! task = 'end' @@ -2000,7 +1930,10 @@ subroutine TRconvert_matel_j0_eigen(jrot) call MPI_File_close(fileh, ierr) #endif else - close(chkptIO,status='keep') + ! Should this be close(iunit) instead of close(chkptIO)? + ! In which case, we don't want to deallocate the ioHandler (formerly chkptIO)... + !close(chkptIO,status='keep') + if (allocated(ioHandler)) deallocate(ioHandler) endif ! ! External field part From 819dbdc0a85aab88a6c14df41792c9a3d6148c7d Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Wed, 4 Aug 2021 18:00:02 +0100 Subject: [PATCH 35/40] Add todos in code --- perturbation.f90 | 1 + test/unit/makefile | 4 ++-- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/perturbation.f90 b/perturbation.f90 index fb62edf..00cd53b 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -16553,6 +16553,7 @@ subroutine PTcontracted_matelem_class(jrot) ! if (trim(job%IOkinet_action)=='SAVE'.and..not.job%IOmatelem_split) then ! + ! FIXME take out MPIIO if (trim(job%kinetmat_format).eq.'MPIIO') then #ifdef TROVE_USE_MPI_ ! call MPI_File_seek(chkptMPIIO, mpioffset, MPI_SEEK_END) diff --git a/test/unit/makefile b/test/unit/makefile index 7b2769c..a7561ee 100644 --- a/test/unit/makefile +++ b/test/unit/makefile @@ -22,5 +22,5 @@ endif clean: $(RM) *.o *.mod *.a *.inc - $(RM) test_io.F90 test_io test.dat - $(RM) test_mpi_io.F90 test_mpi_io test.dat + $(RM) test_io.F90 test_io + $(RM) test_mpi_io.F90 test_mpi_io From e57ee84a0a1c19f327dc0e0f28f2da6fd60c7043 Mon Sep 17 00:00:00 2001 From: Anastasis Georgoulas Date: Thu, 7 Oct 2021 13:33:56 +0100 Subject: [PATCH 36/40] Move script so tests find it --- test/{ => regression}/scripts/set_io_format.sh | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename test/{ => regression}/scripts/set_io_format.sh (100%) diff --git a/test/scripts/set_io_format.sh b/test/regression/scripts/set_io_format.sh similarity index 100% rename from test/scripts/set_io_format.sh rename to test/regression/scripts/set_io_format.sh From a353e5f499fc0968563fffd29dbe9299e699a4f6 Mon Sep 17 00:00:00 2001 From: Anastasis Georgoulas Date: Thu, 7 Oct 2021 16:07:35 +0100 Subject: [PATCH 37/40] Use correct libraries for running tests --- .github/workflows/ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index ad71a74..8ce157c 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -102,4 +102,4 @@ jobs: source /opt/intel/oneapi/mkl/latest/env/vars.sh fi fi - make COMPILER=${COMPILER} test + make COMPILER=${COMPILER} USE_MPI=${USE_MPI} test From 94f0ebfac2ac25af8395d738109b97d3e768247e Mon Sep 17 00:00:00 2001 From: Anastasis Georgoulas Date: Mon, 11 Oct 2021 11:02:43 +0100 Subject: [PATCH 38/40] Determine MPI usage correctly --- makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/makefile b/makefile index f464b7f..8851f8d 100644 --- a/makefile +++ b/makefile @@ -92,7 +92,7 @@ user_pot_dir=. TARGET=$(BINDIR)/$(EXE) MPI_SRCS = -ifdef USE_MPI +ifneq ($(strip $(USE_MPI)),0) MPI_SRCS += io_handler_mpi.f90 endif From b2782c4a570ee1128e96400343b879287841bf20 Mon Sep 17 00:00:00 2001 From: ageorgou <1186102+ageorgou@users.noreply.github.com> Date: Fri, 22 Oct 2021 16:47:39 +0100 Subject: [PATCH 39/40] Fix allocation problems when using Intel (#47) * Don't open file when allocating handler Using source= was causing issues with the Intel compiler, because the "source" handler was immediately deallocated, and the file was accidentally closed. * Fix some build issues on CI --- .github/workflows/ci.yml | 10 +++++++++- io_handler_base.f90 | 11 +++++++++++ io_handler_ftn.f90 | 4 ---- makefile | 6 +++--- perturbation.f90 | 25 +++++++++++-------------- tran.f90 | 13 +++++-------- 6 files changed, 39 insertions(+), 30 deletions(-) diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 8ce157c..f132e5c 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -69,7 +69,15 @@ jobs: run: sudo apt-get install -y intel-mkl - name: Build pFUnit - run: make COMPILER=${COMPILER} install-pfunit + run: | + if [[ -d "/opt/intel/oneapi" ]]; then + source /opt/intel/oneapi/compiler/latest/env/vars.sh + source /opt/intel/oneapi/setvars.sh + if [ ${USE_MPI} = 1 ]; then + source /opt/intel/oneapi/mkl/latest/env/vars.sh + fi + fi + make COMPILER=${COMPILER} install-pfunit - name: Build (gfortran) if: ${{ matrix.compiler == 'gfortran' }} diff --git a/io_handler_base.f90 b/io_handler_base.f90 index 13745bb..eb4e9ff 100644 --- a/io_handler_base.f90 +++ b/io_handler_base.f90 @@ -1,10 +1,12 @@ module io_handler_base use mpi_aux + use errors implicit none type, abstract :: ioHandlerBase contains + procedure(open), deferred :: open generic :: write => writeScalar, write1DArray, write2DArray, write2DArrayDistBlacs, write2DArrayDistColumn procedure(writeScalar), deferred :: writeScalar procedure(write1DArray), deferred :: write1DArray @@ -18,6 +20,15 @@ module io_handler_base end type ioHandlerBase abstract interface + subroutine open(this, fname, err, action, position, status, form, access) + import ioHandlerBase + import ErrorType + class(ioHandlerBase) :: this + type(ErrorType), intent(inout) :: err + character (len = *), intent(in) :: fname + character (len = *), intent(in) :: action + character (len = *), intent(in), optional :: position, status, form, access + end subroutine subroutine writeScalar(this, object) import ioHandlerBase class(ioHandlerBase) :: this diff --git a/io_handler_ftn.f90 b/io_handler_ftn.f90 index c641593..fb48e26 100644 --- a/io_handler_ftn.f90 +++ b/io_handler_ftn.f90 @@ -44,10 +44,6 @@ type(ioHandlerFTN) function newIoHandlerFTN(fname, err, action, position, status character (len = *), intent(in) :: action character (len = *), intent(in), optional :: position, status, form, access - this%isOpen = .false. - this%stat = 0 - this%iounit = 0 - call this%open(fname, err, action, position, status, form, access) end function diff --git a/makefile b/makefile index 8851f8d..bff92c5 100644 --- a/makefile +++ b/makefile @@ -170,7 +170,7 @@ unit-tests-nompi: $(TARGET) echo "Running unit tests without MPI" test/unit/test_io -ifdef USE_MPI +ifneq ($(strip $(USE_MPI)),0) unit-tests-mpi: $(TARGET) $(MAKE) -C test/unit LAPACK="$(LAPACK)" test_mpi_io echo "Running unit tests with MPI" @@ -241,6 +241,6 @@ symmetry.o: symmetry.f90 accuracy.o timer.o timer.o: timer.f90 accuracy.o tran.o: tran.f90 accuracy.o timer.o me_numer.o molecules.o fields.o moltype.o symmetry.o perturbation.o mpi_aux.o trove.o: trove.f90 accuracy.o fields.o perturbation.o symmetry.o timer.o moltype.o dipole.o refinement.o tran.o extfield.o -io_handler_base.o: io_handler_base.f90 mpi_aux.o +io_handler_base.o: io_handler_base.f90 errors.o mpi_aux.o io_handler_ftn.o: io_handler_ftn.f90 io_handler_base.o errors.o mpi_aux.o -io_handler_mpi.o: io_handler_mpi.f90 io_handler_base.o mpi_aux.o +io_handler_mpi.o: io_handler_mpi.f90 io_handler_base.o errors.o mpi_aux.o diff --git a/perturbation.f90 b/perturbation.f90 index ef62dd6..86f6a41 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -16226,16 +16226,13 @@ subroutine PTcontracted_matelem_class(jrot) call IOStart(trim(job_is),chkptIO) ! #ifdef TROVE_USE_MPI_ - allocate(ioHandler, & - source=ioHandlerMPI(& - job%kinetmat_file, err, & - action='write', position='rewind', status='replace', form='unformatted')) + allocate(ioHandlerMPI::ioHandler) #else - allocate(ioHandler, & - source=ioHandlerFTN(& - job%kinetmat_file, err, & - action='write', position='rewind', status='replace', form='unformatted')) + allocate(ioHandlerFTN::ioHandler) #endif + call ioHandler%open(& + job%kinetmat_file, err, & + action='write', position='rewind', status='replace', form='unformatted') HANDLE_ERROR(err) call ioHandler%write('Start Kinetic part') @@ -17877,10 +17874,10 @@ subroutine PTcontracted_matelem_class_fast_II(jrot) job_is ='Vib. matrix elements of the rot. kinetic part' call IOStart(trim(job_is),chkptIO) - allocate(ioHandler, & - source=ioHandlerFTN(& + allocate(ioHandlerFTN::ioHandler) + call ioHandler%open( & job%kinetmat_file, err, & - action='write', position='rewind', status='replace', form='unformatted')) + action='write', position='rewind', status='replace', form='unformatted') HANDLE_ERROR(err) call ioHandler%write('Start Kinetic part') ! @@ -38297,10 +38294,10 @@ subroutine PTcontracted_matelem_class_fast(jrot) job_is ='Vib. matrix elements of the rot. kinetic part' call IOStart(trim(job_is),chkptIO) ! - allocate(ioHandler, & - source=ioHandlerFTN(& + allocate(ioHandlerFTN::ioHandler) + call ioHandler%open(& job%kinetmat_file, err, & - action='write', position='rewind', status='replace', form='unformatted')) + action='write', position='rewind', status='replace', form='unformatted') HANDLE_ERROR(err) call ioHandler%write('Start Kinetic part') diff --git a/tran.f90 b/tran.f90 index 8070cbc..db13c45 100644 --- a/tran.f90 +++ b/tran.f90 @@ -1614,16 +1614,13 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! call IOStart(trim(job_is),chkptIO) #ifdef TROVE_USE_MPI_ - allocate(ioHandler, & - source=ioHandlerMPI(& - job%kineteigen_file, err, & - action='write', position='rewind', status='replace', form='unformatted')) + allocate(ioHandlerMPI::ioHandler) #else - allocate(ioHandler, & - source=ioHandlerFTN(& - job%kineteigen_file, err, & - action='write', position='rewind', status='replace', form='unformatted')) + allocate(ioHandlerFTN::ioHandler) #endif + call ioHandler%open(& + job%kineteigen_file, err, & + action='write', position='rewind', status='replace', form='unformatted') HANDLE_ERROR(err) call ioHandler%write('Start Kinetic part') From 4cfa94196eba836858a810cfefed9fb48b60c19e Mon Sep 17 00:00:00 2001 From: ageorgou <1186102+ageorgou@users.noreply.github.com> Date: Fri, 22 Oct 2021 16:57:53 +0100 Subject: [PATCH 40/40] Fix case of skipping g_cor header with MPI writer (#43) --- perturbation.f90 | 16 +--------------- 1 file changed, 1 insertion(+), 15 deletions(-) diff --git a/perturbation.f90 b/perturbation.f90 index 86f6a41..eb78c07 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -16490,21 +16490,7 @@ subroutine PTcontracted_matelem_class(jrot) if (job%verbose>=2) write(out,"(/'Coriolis part of the Kinetic energy operator...')") ! if (trim(job%IOkinet_action)=='SAVE'.and..not.job%IOmatelem_split) then - ! - ! FIXME take out MPIIO - if (trim(job%kinetmat_format).eq.'MPIIO') then -#ifdef TROVE_USE_MPI_ - ! call MPI_File_seek(chkptMPIIO, mpioffset, MPI_SEEK_END) - if(mpi_rank.eq.0) then - call MPI_File_write_shared(chkptMPIIO,'g_cor',5,mpi_character,mpi_status_ignore,ierr) - !else - ! call MPI_File_write_shared(chkptMPIIO,'',0,mpi_character,mpi_status_ignore,ierr) - endif -#endif - else - call ioHandler%write('g_cor') - endif - ! + call ioHandler%write('g_cor') endif ! ! Run the loop over all term of the expansion of the Hamiltonian