From 5bd85ff007cf4714919766eddf53cb885761e3f2 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 30 Sep 2021 14:35:51 +0100 Subject: [PATCH 01/66] Fix line length issue with MPI_WRAPPER when using gfortran --- io_handler_mpi.f90 | 9 +++------ makefile | 2 +- 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/io_handler_mpi.f90 b/io_handler_mpi.f90 index 4d12362..ec1060b 100644 --- a/io_handler_mpi.f90 +++ b/io_handler_mpi.f90 @@ -195,8 +195,7 @@ subroutine writeScalarMPI(this, object) call MPI_File_write(this%fileh, byteSize, 1, MPI_INTEGER, & MPI_STATUS_IGNORE, ierr) - MPI_WRAPPER(MPI_File_write, this%fileh, object, length, mpiType, & - MPI_STATUS_IGNORE, ierr) + 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) end subroutine @@ -229,8 +228,7 @@ subroutine write2DArrayMPI(this, object) call MPI_File_write(this%fileh, arrSizeBytes, 1, MPI_INTEGER, & MPI_STATUS_IGNORE, ierr) - MPI_WRAPPER(MPI_File_write, this%fileh, object, globalSize, mpiType, & - MPI_STATUS_IGNORE, ierr) + 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) end subroutine @@ -267,8 +265,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 - MPI_WRAPPER(MPI_File_write_all, this%fileh, object, size(object), mpiType, & - MPI_STATUS_IGNORE, ierr) + 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 ! Reset file view back to regular ol bytes diff --git a/makefile b/makefile index e9c665f..f5fbf2f 100644 --- a/makefile +++ b/makefile @@ -35,7 +35,7 @@ ifeq ($(strip $(COMPILER)),intel) ########## else ifeq ($(strip $(COMPILER)),gfortran) FC = gfortran - FFLAGS = -cpp -std=gnu -fopenmp -march=native -ffree-line-length-512 -fcray-pointer -I$(OBJDIR) -J$(OBJDIR) + FFLAGS = -cpp -std=gnu -fopenmp -march=native -ffree-line-length-none -fcray-pointer -I$(OBJDIR) -J$(OBJDIR) GCC_VERSION_GT_10 := $(shell expr `gcc -dumpversion | cut -f1 -d.` \>= 10) ifeq "${GCC_VERSION_GT_10}" "1" From cecf9bc6e8ae1cbbd41742ef63d9b28a041d663c Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 30 Sep 2021 14:37:08 +0100 Subject: [PATCH 02/66] Flag very dangerous and confusing line in tests --- test/unit/test_mpi_io.pf | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/unit/test_mpi_io.pf b/test/unit/test_mpi_io.pf index 537c347..87b04ee 100644 --- a/test/unit/test_mpi_io.pf +++ b/test/unit/test_mpi_io.pf @@ -21,7 +21,7 @@ module test_mpi_io integer,external :: INDXL2G logical :: is_mpi_initialised = .false. - integer, parameter :: totalTestCount = 2 + integer, parameter :: totalTestCount = 2 ! CHANGE ME TO NUMBER OF TESTS integer :: currentTestCount = 0 contains From c4dbba2261c312b6384e3a7298fbd6c1174ad917 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Tue, 19 Oct 2021 14:41:22 +0100 Subject: [PATCH 03/66] Add test for reading with MPI --- io_handler_base.f90 | 10 ++- io_handler_ftn.f90 | 12 ++++ io_handler_mpi.f90 | 68 ++++++++++++++---- test/unit/test_mpi_io.pf | 151 +++++++++++++++++++++++++++++++++++---- tran.f90 | 43 ++++++----- 5 files changed, 234 insertions(+), 50 deletions(-) diff --git a/io_handler_base.f90 b/io_handler_base.f90 index 13745bb..11fa010 100644 --- a/io_handler_base.f90 +++ b/io_handler_base.f90 @@ -11,10 +11,11 @@ module io_handler_base procedure(write2DArray), deferred :: write2DArray procedure(write2DArrayDistBlacs), deferred :: write2DArrayDistBlacs procedure(write2DArrayDistColumn), deferred :: write2DArrayDistColumn - generic :: read => readScalar, read1DArray, read2DArray + generic :: read => readScalar, read1DArray, read2DArray, read2DArrayDistBlacs procedure(readScalar), deferred :: readScalar procedure(read1DArray), deferred :: read1DArray procedure(read2DArray), deferred :: read2DArray + procedure(read2DArrayDistBlacs), deferred :: read2DArrayDistBlacs end type ioHandlerBase abstract interface @@ -63,6 +64,13 @@ subroutine read2DArray(this, object) class(ioHandlerBase) :: this class(*), dimension(:,:), intent(out) :: object end subroutine + subroutine read2DArrayDistBlacs(this, object, block_type) + import ioHandlerBase + import MPI_Datatype + class(ioHandlerBase) :: this + class(*), dimension(:,:), intent(out) :: object + type(MPI_Datatype), intent(in) :: block_type + end subroutine end interface private diff --git a/io_handler_ftn.f90 b/io_handler_ftn.f90 index c641593..3a6aff9 100644 --- a/io_handler_ftn.f90 +++ b/io_handler_ftn.f90 @@ -21,6 +21,7 @@ module io_handler_ftn procedure :: readScalar => readScalarFTN procedure :: read1DArray => read1DArrayFTN procedure :: read2DArray => read2DArrayFTN + procedure :: read2DArrayDistBlacs => read2DArrayDistBlacsFTN procedure :: open procedure :: close final :: destroyIoHandlerFTN @@ -240,4 +241,15 @@ subroutine read2DArrayFTN(this, object) print *, "Unsupported type!" end select end subroutine + + subroutine read2DArrayDistBlacsFTN(this, object, block_type) + ! Write arrays distributed as columns using co_distr_data + + class(ioHandlerFTN) :: this + class(*), dimension(:,:), intent(out) :: object + type(MPI_Datatype), intent(in) :: block_type + + ! Using the fortran io_handler means array isn't distributed, just write normally + call this%read2DArray(object) + end subroutine end module diff --git a/io_handler_mpi.f90 b/io_handler_mpi.f90 index ec1060b..1418d66 100644 --- a/io_handler_mpi.f90 +++ b/io_handler_mpi.f90 @@ -44,6 +44,7 @@ module io_handler_mpi procedure :: readScalar => readScalarMPI procedure :: read1DArray => read1DArrayMPI procedure :: read2DArray => read2DArrayMPI + procedure :: read2DArrayDistBlacs => read2DArrayDistBlacsMPI procedure :: open procedure :: close final :: destroyIoHandlerMPI @@ -113,7 +114,7 @@ subroutine open(this, fname, err, action, position, status, form, access) end if print *, "MPI: Opening ", trim(fname), " with ", \ - trim(positionVal), " ", trim(statusVal), " ", trim(formVal), " ", trim(accessVal) + trim(action), " ", trim(positionVal), " ", trim(statusVal), " ", trim(formVal), " ", trim(accessVal) ! FIXME use above flags to change open behaviour @@ -122,7 +123,7 @@ subroutine open(this, fname, err, action, position, status, form, access) ! 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 + else if(trim(action) == 'read') then call MPI_File_open(MPI_COMM_WORLD, fname, MPI_MODE_RDONLY, MPI_INFO_NULL, this%fileh, ierr) endif @@ -223,6 +224,7 @@ subroutine write2DArrayMPI(this, object) this%offset = this%offset + 4 + arrSizeBytes + 4 if (this%rank /= 0) then + call MPI_File_seek(this%fileh, this%offset, MPI_SEEK_SET, ierr) return end if @@ -311,30 +313,70 @@ subroutine write2DArrayDistColumnMPI(this, object, mdimen) subroutine readScalarMPI(this, object) class(ioHandlerMPI) :: this class(*), intent(out) :: object - print *, "reading object to MPI IO" - ! Example object handling + + integer :: byteSize, ierr, length + integer(kind = MPI_OFFSET_KIND) :: offset + type(MPI_Datatype) :: mpiType + + call getMPIVarInfo(object, byteSize, mpiType) + select type(object) - type is (integer) - print *, object - type is (real) - print *, object - type is (complex) - print *, object + type is (character(len=*)) + length = len(object) class default - print *, "Unsupported type!" + length = 1 end select + + call MPI_File_get_position(this%fileh, offset, ierr) + call MPI_File_set_view(this%fileh, offset+4, MPI_BYTE, MPI_BYTE, & + 'native', MPI_INFO_NULL, ierr) + MPI_WRAPPER(MPI_File_read_all, this%fileh, object, length, mpiType, MPI_STATUS_IGNORE, ierr) + call MPI_File_get_position(this%fileh, offset, ierr) + call MPI_File_set_view(this%fileh, offset+4, MPI_BYTE, MPI_BYTE, & + 'native', MPI_INFO_NULL, ierr) end subroutine subroutine read1DArrayMPI(this, object) class(ioHandlerMPI) :: this class(*), dimension(:), intent(out) :: object - print *, "reading 1D array to MPI IO" + stop "reading 1D array with MPI IO not supported" end subroutine subroutine read2DArrayMPI(this, object) class(ioHandlerMPI) :: this class(*), dimension(:,:), intent(out) :: object - print *, "reading 2D array to MPI IO" + stop "reading 2D array with MPI IO without specifying distribution not supported" + end subroutine + + subroutine read2DArrayDistBlacsMPI(this, object, block_type) + class(ioHandlerMPI) :: this + class(*), intent(out) :: 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) :: offset + + !integer :: dims(2) + + !dims(:) = descr(3:4) + !globalSize = dims(1)*dims(2) + + !call getMPIVarInfo(object(1,1), byteSize, mpiType) + !arrSizeBytes = globalSize*byteSize + + call MPI_File_get_position(this%fileh, offset, ierr) + ! Set file view including offsetting bookend + call MPI_File_set_view(this%fileh, offset+4, mpiType, block_type, & + 'native', MPI_INFO_NULL, ierr) + ! Read array in parallel + MPI_WRAPPER(MPI_File_read_all, this%fileh, object, size(object), mpiType, MPI_STATUS_IGNORE, ierr) + call MPI_File_get_position(this%fileh, offset, ierr) + ! Reset file view back to regular ol bytes + call MPI_File_set_view(this%fileh, offset+4, MPI_BYTE, MPI_BYTE, & + 'native', MPI_INFO_NULL, ierr) end subroutine end module diff --git a/test/unit/test_mpi_io.pf b/test/unit/test_mpi_io.pf index 87b04ee..4bbe04b 100644 --- a/test/unit/test_mpi_io.pf +++ b/test/unit/test_mpi_io.pf @@ -21,7 +21,7 @@ module test_mpi_io integer,external :: INDXL2G logical :: is_mpi_initialised = .false. - integer, parameter :: totalTestCount = 2 ! CHANGE ME TO NUMBER OF TESTS + integer, parameter :: totalTestCount = 3 ! CHANGE ME TO NUMBER OF TESTS integer :: currentTestCount = 0 contains @@ -73,20 +73,11 @@ module test_mpi_io integer :: ierr, rank, allocinfo = 0 + ! Set up MPI call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr) if(ierr.ne.0) print *, "Error: could not get rank" - call ioHandler%open(fname, err, action='write', & - form=form, access=access, status=status, position=position) - HANDLE_ERROR(err) - - ! Test writing scalars - call ioHandler%write(true_integer) ! int - call ioHandler%write(true_real) ! double - call ioHandler%write(true_complex) ! complex - call ioHandler%write(true_str) ! string - - ! Test writing an array + ! Set up 2D 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" @@ -104,16 +95,28 @@ module test_mpi_io end do end do + ! Write + call ioHandler%open(fname, err, action='write', & + form=form, access=access, status=status, position=position) + HANDLE_ERROR(err) + + ! Test writing scalars + call ioHandler%write(true_integer) ! int + call ioHandler%write(true_real) ! double + call ioHandler%write(true_complex) ! complex + call ioHandler%write(true_str) ! string + + ! Test writing an array call ioHandler%write(array2D, array2D_descr, array2D_block_type) ! Test writing something after array - call ioHandler%write(true_integer) ! int + call ioHandler%write(true_integer) ! Test writing another array call ioHandler%write(array2D, array2D_descr, array2D_block_type) ! Test writing something after 2nd array - call ioHandler%write(true_integer) ! int + call ioHandler%write(true_integer) call ioHandler%close() @@ -273,4 +276,124 @@ module test_mpi_io endif end subroutine testMPIWritingColumnDistArray + + @test + subroutine testMPIReading(this) + class(TestMPI), intent(inout) :: this + type(ioHandlerMPI) :: ioHandler + + integer, parameter :: array2DNRow = 4 + integer, parameter :: array2DNCol = 3 + real(rk) :: array2D(array2DNRow,array2DNCol) + real(rk), allocatable :: in_array2D(:,:) + integer :: array2D_descr(9) = 0 + type(MPI_Datatype) :: array2D_block_type + + 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" + character(len=*), parameter :: position = "asis" + character(len=*), parameter :: status = "unknown" + character(len=*), parameter :: form = "unformatted" + character(len=*), parameter :: access = "sequential" + + integer i, j + integer :: gi = 0, gj = 0, MB, NB, RSRC, CSRC + integer :: ierr, rank, allocinfo = 0 + type(ErrorType) :: err + + ! Set up 2D array + do i=1,array2DNRow + do j=1,array2DNCol + array2D(i,j) = array2DNCol*(i-1) + j + end do + end do + + ! Set up MPI + call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr) + if(ierr.ne.0) print *, "Error: could not get rank" + + ! Set up 2D array block type + call co_block_type_init(in_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) + + RSRC = array2D_descr(7) + CSRC = array2D_descr(8) + + ! Write test file + if(rank == 0) then + open(newunit=iounit, iostat=stat, action='write', file=fname, & + form=form, access=access, status=status, position=position) + + write(iounit) true_integer ! int + !write(iounit) true_real ! double + !write(iounit) true_complex ! complex + !write(iounit) true_str ! string + !write(iounit) array2D ! 2D array + !write(iounit) true_integer ! int + !write(iounit) array2D ! 2D array + !write(iounit) true_integer ! int + + if (stat == 0) close(iounit) + endif + + call MPI_Barrier(MPI_COMM_WORLD) + + ! Read test file + call ioHandler%open(fname, err, \ + action='read', form=form, access=access, status=status, position=position) + HANDLE_ERROR(err) + + call ioHandler%read(in_integer) + @assertTrue(in_integer == true_integer) + + !call ioHandler%read(in_real) + !@assertTrue(in_real == true_real) + + !call ioHandler%read(in_complex) + !@assertTrue(in_complex == true_complex) + + !call ioHandler%read(in_str) + !@assertTrue(in_str == true_str) + + !!call ioHandler%read(in_array2D, array2D_block_type) + !!do i=1,size(in_array2D,1) + !!do j=1,size(in_array2D,2) + !!gi = INDXL2G (i, MB, myprow, RSRC, nprow) + !!gj = INDXL2G (j, NB, mypcol, CSRC, npcol) + !!@assertTrue(in_array2D(i,j) == array2DNCol*(gi-1) + (gj)) + !!end do + !!end do + + !!call ioHandler%read(true_integer) + !!@assertTrue(in_integer == true_integer) + + !!call ioHandler%read(in_array2D, array2D_block_type) + !!do i=1,size(in_array2D,1) + !!do j=1,size(in_array2D,2) + !!gi = INDXL2G (i, MB, myprow, RSRC, nprow) + !!gj = INDXL2G (j, NB, mypcol, CSRC, npcol) + !!@assertTrue(in_array2D(i,j) == array2DNCol*(gi-1) + (gj)) + !!end do + !!end do + + !!call ioHandler%read(true_integer) + !!@assertTrue(in_integer == true_integer) + + call ioHandler%close() + + !if(rank == 0) then + !! Cleanup test file + !open(newunit=iounit, iostat=stat, action='read', file=fname) + !if (stat == 0) close(iounit, status='delete') + !endif + + end subroutine end module diff --git a/tran.f90 b/tran.f90 index 8070cbc..4601434 100644 --- a/tran.f90 +++ b/tran.f90 @@ -1716,11 +1716,7 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! if (job%IOmatelem_split.and..not.job%vib_rot_contr) then ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - call divided_slice_read_mpi(islice,'g_rot',job%matelem_suffix,dimen,gmat,gmat_block_type,ierror) - else - call divided_slice_read(islice,'g_rot',job%matelem_suffix,dimen,gmat,ierror) - endif + call divided_slice_read(islice,'g_rot',job%matelem_suffix,dimen,gmat,gmat_block_type,ierror) ! elseif (job%IOmatelem_split.and.job%vib_rot_contr) then ! @@ -1832,11 +1828,7 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! if (job%IOmatelem_split.and..not.job%vib_rot_contr) then ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - call divided_slice_read_mpi(islice,'g_cor',job%matelem_suffix,dimen,gmat,gmat_block_type,ierror) - else - call divided_slice_read(islice,'g_cor',job%matelem_suffix,dimen,gmat,ierror) - endif + call divided_slice_read(islice,'g_cor',job%matelem_suffix,dimen,gmat,gmat_block_type,ierror) ! elseif (job%IOmatelem_split.and.job%vib_rot_contr) then ! @@ -2080,11 +2072,7 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! if (job%IOextF_divide) then ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - call divided_slice_read_mpi(imu,'extF',job%extmat_suffix,dimen,extF_me,extF_block_type,ierror) - else - call divided_slice_read(imu,'extF',job%extmat_suffix,dimen,extF_me,ierror) - endif + call divided_slice_read(imu,'extF',job%extmat_suffix,dimen,extF_me,extF_block_type,ierror) ! if (ierror==1) cycle ! @@ -2353,17 +2341,18 @@ subroutine divided_slice_write_mpi(islice,name,suffix,N,field,block_type) end subroutine divided_slice_write_mpi ! ! - subroutine divided_slice_read(islice,name,suffix,N,field,ierror) + subroutine divided_slice_read(islice,name,suffix,N,field,block_type,ierror) ! implicit none ! integer(ik),intent(in) :: islice character(len=*),intent(in) :: name,suffix integer(ik),intent(in) :: N + type(MPI_Datatype),intent(in) :: block_type real(rk),intent(out) :: field(N,N) integer(ik),intent(out) :: ierror character(len=4) :: jchar - integer(ik) :: chkptIO + class(ioHandlerBase), allocatable :: ioHandler character(len=cl) :: buf,filename,job_is integer(ik) :: ilen logical :: ifopened @@ -2378,25 +2367,35 @@ subroutine divided_slice_read(islice,name,suffix,N,field,ierror) ! filename = trim(suffix)//trim(adjustl(jchar))//'.chk' ! - open(chkptIO,form='unformatted',action='read',position='rewind',status='old',file=filename,err=15) +#ifdef TROVE_USE_MPI_ + allocate(ioHandler, & + source=ioHandlerMPI(& + job%kineteigen_file, err, & + action='read', position='rewind', status='old', form='unformatted')) +#else + allocate(ioHandler, & + source=ioHandlerFTN(& + job%kineteigen_file, err, & + action='read', position='rewind', status='old', form='unformatted')) +#endif ! ilen = LEN_TRIM(name) ! - read(chkptIO) buf(1:ilen) + call ioHandler%read(buf(1:ilen)) if ( trim(buf(1:ilen))/=trim(name) ) then write (out,"(' kinetic divided_slice_read in slice ',a20,': header is missing or wrong',a)") filename,buf(1:ilen) stop 'divided_slice_read - in slice - header missing or wrong' end if ! - read(chkptIO) field + call ioHandler%read(field, extF_block_type) ! - read(chkptIO) buf(1:ilen) + call ioHandler%read(buf(1:ilen)) if ( trim(buf(1:ilen))/=trim(name) ) then write (out,"(' kinetic divided_slice_read in slice ',a20,': header is missing or wrong',a)") filename,buf(1:ilen) stop 'divided_slice_read - in slice - header missing or wrong' end if ! - close(chkptIO) + deallocate(ioHandler) ! return ! From f1fb37aa6ef38d567c928d683a84c450c5328e7a Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Tue, 19 Oct 2021 14:50:27 +0100 Subject: [PATCH 04/66] Reading real and complex numbers working with MPI reader --- io_handler_mpi.f90 | 8 ++------ test/unit/test_mpi_io.pf | 12 ++++++------ 2 files changed, 8 insertions(+), 12 deletions(-) diff --git a/io_handler_mpi.f90 b/io_handler_mpi.f90 index 1418d66..dc13534 100644 --- a/io_handler_mpi.f90 +++ b/io_handler_mpi.f90 @@ -327,13 +327,9 @@ subroutine readScalarMPI(this, object) length = 1 end select - call MPI_File_get_position(this%fileh, offset, ierr) - call MPI_File_set_view(this%fileh, offset+4, MPI_BYTE, MPI_BYTE, & - 'native', MPI_INFO_NULL, ierr) + call MPI_File_seek(this%fileh, int(4,MPI_OFFSET_KIND), MPI_SEEK_CUR, ierr) MPI_WRAPPER(MPI_File_read_all, this%fileh, object, length, mpiType, MPI_STATUS_IGNORE, ierr) - call MPI_File_get_position(this%fileh, offset, ierr) - call MPI_File_set_view(this%fileh, offset+4, MPI_BYTE, MPI_BYTE, & - 'native', MPI_INFO_NULL, ierr) + call MPI_File_seek(this%fileh, int(4,MPI_OFFSET_KIND), MPI_SEEK_CUR, ierr) end subroutine subroutine read1DArrayMPI(this, object) diff --git a/test/unit/test_mpi_io.pf b/test/unit/test_mpi_io.pf index 4bbe04b..92db8c7 100644 --- a/test/unit/test_mpi_io.pf +++ b/test/unit/test_mpi_io.pf @@ -333,8 +333,8 @@ module test_mpi_io form=form, access=access, status=status, position=position) write(iounit) true_integer ! int - !write(iounit) true_real ! double - !write(iounit) true_complex ! complex + write(iounit) true_real ! double + write(iounit) true_complex ! complex !write(iounit) true_str ! string !write(iounit) array2D ! 2D array !write(iounit) true_integer ! int @@ -354,11 +354,11 @@ module test_mpi_io call ioHandler%read(in_integer) @assertTrue(in_integer == true_integer) - !call ioHandler%read(in_real) - !@assertTrue(in_real == true_real) + call ioHandler%read(in_real) + @assertTrue(in_real == true_real) - !call ioHandler%read(in_complex) - !@assertTrue(in_complex == true_complex) + call ioHandler%read(in_complex) + @assertTrue(in_complex == true_complex) !call ioHandler%read(in_str) !@assertTrue(in_str == true_str) From 5ffaaf2223f326de489cb95b8777274da3672995 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Tue, 19 Oct 2021 17:19:28 +0100 Subject: [PATCH 05/66] Reading BLACS-distributed array now works with MPI reader --- io_handler_base.f90 | 3 +- io_handler_ftn.f90 | 3 +- io_handler_mpi.f90 | 29 ++++---- test/unit/test_mpi_io.pf | 145 ++++++++++++++++++++++++++------------- tran.f90 | 11 +-- 5 files changed, 123 insertions(+), 68 deletions(-) diff --git a/io_handler_base.f90 b/io_handler_base.f90 index 11fa010..1b83a14 100644 --- a/io_handler_base.f90 +++ b/io_handler_base.f90 @@ -64,11 +64,12 @@ subroutine read2DArray(this, object) class(ioHandlerBase) :: this class(*), dimension(:,:), intent(out) :: object end subroutine - subroutine read2DArrayDistBlacs(this, object, block_type) + subroutine read2DArrayDistBlacs(this, object, descr, block_type) import ioHandlerBase import MPI_Datatype class(ioHandlerBase) :: this class(*), dimension(:,:), intent(out) :: object + integer, intent(in) :: descr(9) ! Description array outputted from co_block_type_init type(MPI_Datatype), intent(in) :: block_type end subroutine end interface diff --git a/io_handler_ftn.f90 b/io_handler_ftn.f90 index 3a6aff9..c210f82 100644 --- a/io_handler_ftn.f90 +++ b/io_handler_ftn.f90 @@ -242,11 +242,12 @@ subroutine read2DArrayFTN(this, object) end select end subroutine - subroutine read2DArrayDistBlacsFTN(this, object, block_type) + subroutine read2DArrayDistBlacsFTN(this, object, descr, block_type) ! Write arrays distributed as columns using co_distr_data class(ioHandlerFTN) :: this class(*), dimension(:,:), intent(out) :: object + integer, intent(in) :: descr(9) ! Description array outputted from co_block_type_init type(MPI_Datatype), intent(in) :: block_type ! Using the fortran io_handler means array isn't distributed, just write normally diff --git a/io_handler_mpi.f90 b/io_handler_mpi.f90 index dc13534..d83c7ad 100644 --- a/io_handler_mpi.f90 +++ b/io_handler_mpi.f90 @@ -344,34 +344,35 @@ subroutine read2DArrayMPI(this, object) stop "reading 2D array with MPI IO without specifying distribution not supported" end subroutine - subroutine read2DArrayDistBlacsMPI(this, object, block_type) + subroutine read2DArrayDistBlacsMPI(this, object, descr, block_type) class(ioHandlerMPI) :: this class(*), intent(out) :: object(:,:) - !integer, intent(in) :: descr(9) ! Description array outputted from co_block_type_init + 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) :: offset + integer :: byteSize, arrSizeBytes, globalSize, ierr + integer(kind = MPI_OFFSET_KIND) :: offset, disp - !integer :: dims(2) + integer :: dims(2) - !dims(:) = descr(3:4) - !globalSize = dims(1)*dims(2) + call getMPIVarInfo(object(1,1), byteSize, mpiType) - !call getMPIVarInfo(object(1,1), byteSize, mpiType) - !arrSizeBytes = globalSize*byteSize + dims(:) = descr(3:4) + globalSize = dims(1)*dims(2) + + call getMPIVarInfo(object(1,1), byteSize, mpiType) + arrSizeBytes = globalSize*byteSize call MPI_File_get_position(this%fileh, offset, ierr) + ! Get initial displacement in file + call MPI_File_get_byte_offset(this%fileh, offset, disp, ierr) ! Set file view including offsetting bookend call MPI_File_set_view(this%fileh, offset+4, mpiType, block_type, & 'native', MPI_INFO_NULL, ierr) ! Read array in parallel MPI_WRAPPER(MPI_File_read_all, this%fileh, object, size(object), mpiType, MPI_STATUS_IGNORE, ierr) - call MPI_File_get_position(this%fileh, offset, ierr) - ! Reset file view back to regular ol bytes - call MPI_File_set_view(this%fileh, offset+4, MPI_BYTE, MPI_BYTE, & + ! Reset file view back to regular ol bytes, including bookends and array we've just written + call MPI_File_set_view(this%fileh, disp+4+arrSizeBytes+4, MPI_BYTE, MPI_BYTE, & 'native', MPI_INFO_NULL, ierr) end subroutine diff --git a/test/unit/test_mpi_io.pf b/test/unit/test_mpi_io.pf index 92db8c7..6203432 100644 --- a/test/unit/test_mpi_io.pf +++ b/test/unit/test_mpi_io.pf @@ -21,7 +21,7 @@ module test_mpi_io integer,external :: INDXL2G logical :: is_mpi_initialised = .false. - integer, parameter :: totalTestCount = 3 ! CHANGE ME TO NUMBER OF TESTS + integer, parameter :: totalTestCount = 4 ! CHANGE ME TO NUMBER OF TESTS integer :: currentTestCount = 0 contains @@ -278,7 +278,73 @@ module test_mpi_io end subroutine testMPIWritingColumnDistArray @test - subroutine testMPIReading(this) + subroutine testMPIReadScalars(this) + class(TestMPI), intent(inout) :: this + type(ioHandlerMPI) :: ioHandler + + 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" + character(len=*), parameter :: position = "asis" + character(len=*), parameter :: status = "unknown" + character(len=*), parameter :: form = "unformatted" + character(len=*), parameter :: access = "sequential" + + integer :: ierr, rank, allocinfo = 0 + type(ErrorType) :: err + + ! Set up MPI + call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr) + if(ierr.ne.0) print *, "Error: could not get rank" + + ! Write test file + if(rank == 0) then + open(newunit=iounit, iostat=stat, action='write', file=fname, & + form=form, access=access, status=status, position=position) + + write(iounit) true_integer ! int + write(iounit) true_real ! double + write(iounit) true_complex ! complex + write(iounit) true_str ! string + + if (stat == 0) close(iounit) + endif + + call MPI_Barrier(MPI_COMM_WORLD) + + ! Read test file + call ioHandler%open(fname, err, \ + action='read', form=form, access=access, status=status, position=position) + HANDLE_ERROR(err) + + call ioHandler%read(in_integer) + @assertTrue(in_integer == true_integer) + + call ioHandler%read(in_real) + @assertTrue(in_real == true_real) + + call ioHandler%read(in_complex) + @assertTrue(in_complex == true_complex) + + call ioHandler%read(in_str) + @assertTrue(in_str == true_str) + + call ioHandler%close() + + if(rank == 0) then + ! Cleanup test file + open(newunit=iounit, iostat=stat, action='read', file=fname) + if (stat == 0) close(iounit, status='delete') + endif + + end subroutine + + @test + subroutine testMPIReadBlasDistArray(this) class(TestMPI), intent(inout) :: this type(ioHandlerMPI) :: ioHandler @@ -289,10 +355,7 @@ module test_mpi_io integer :: array2D_descr(9) = 0 type(MPI_Datatype) :: array2D_block_type - 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" @@ -333,13 +396,10 @@ module test_mpi_io form=form, access=access, status=status, position=position) write(iounit) true_integer ! int - write(iounit) true_real ! double - write(iounit) true_complex ! complex - !write(iounit) true_str ! string - !write(iounit) array2D ! 2D array - !write(iounit) true_integer ! int - !write(iounit) array2D ! 2D array - !write(iounit) true_integer ! int + write(iounit) array2D ! 2D array + write(iounit) true_integer ! int + write(iounit) array2D ! 2D array + write(iounit) true_integer ! int if (stat == 0) close(iounit) endif @@ -354,46 +414,37 @@ module test_mpi_io call ioHandler%read(in_integer) @assertTrue(in_integer == true_integer) - call ioHandler%read(in_real) - @assertTrue(in_real == true_real) + call ioHandler%read(in_array2D, array2D_descr, array2D_block_type) + do i=1,size(in_array2D,1) + do j=1,size(in_array2D,2) + gi = INDXL2G (i, MB, myprow, RSRC, nprow) + gj = INDXL2G (j, NB, mypcol, CSRC, npcol) + @assertTrue(in_array2D(i,j) == array2DNCol*(gi-1) + (gj)) + end do + end do - call ioHandler%read(in_complex) - @assertTrue(in_complex == true_complex) + call ioHandler%read(true_integer) + @assertTrue(in_integer == true_integer) + + call ioHandler%read(in_array2D, array2D_descr, array2D_block_type) + do i=1,size(in_array2D,1) + do j=1,size(in_array2D,2) + gi = INDXL2G (i, MB, myprow, RSRC, nprow) + gj = INDXL2G (j, NB, mypcol, CSRC, npcol) + @assertTrue(in_array2D(i,j) == array2DNCol*(gi-1) + (gj)) + end do + end do - !call ioHandler%read(in_str) - !@assertTrue(in_str == true_str) - - !!call ioHandler%read(in_array2D, array2D_block_type) - !!do i=1,size(in_array2D,1) - !!do j=1,size(in_array2D,2) - !!gi = INDXL2G (i, MB, myprow, RSRC, nprow) - !!gj = INDXL2G (j, NB, mypcol, CSRC, npcol) - !!@assertTrue(in_array2D(i,j) == array2DNCol*(gi-1) + (gj)) - !!end do - !!end do - - !!call ioHandler%read(true_integer) - !!@assertTrue(in_integer == true_integer) - - !!call ioHandler%read(in_array2D, array2D_block_type) - !!do i=1,size(in_array2D,1) - !!do j=1,size(in_array2D,2) - !!gi = INDXL2G (i, MB, myprow, RSRC, nprow) - !!gj = INDXL2G (j, NB, mypcol, CSRC, npcol) - !!@assertTrue(in_array2D(i,j) == array2DNCol*(gi-1) + (gj)) - !!end do - !!end do - - !!call ioHandler%read(true_integer) - !!@assertTrue(in_integer == true_integer) + call ioHandler%read(true_integer) + @assertTrue(in_integer == true_integer) call ioHandler%close() - !if(rank == 0) then - !! Cleanup test file - !open(newunit=iounit, iostat=stat, action='read', file=fname) - !if (stat == 0) close(iounit, status='delete') - !endif + if(rank == 0) then + ! Cleanup test file + open(newunit=iounit, iostat=stat, action='read', file=fname) + if (stat == 0) close(iounit, status='delete') + endif end subroutine end module diff --git a/tran.f90 b/tran.f90 index 4601434..c99e543 100644 --- a/tran.f90 +++ b/tran.f90 @@ -1716,7 +1716,7 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! if (job%IOmatelem_split.and..not.job%vib_rot_contr) then ! - call divided_slice_read(islice,'g_rot',job%matelem_suffix,dimen,gmat,gmat_block_type,ierror) + call divided_slice_read(islice,'g_rot',job%matelem_suffix,dimen,gmat,desc_gmat,gmat_block_type,ierror) ! elseif (job%IOmatelem_split.and.job%vib_rot_contr) then ! @@ -1828,7 +1828,7 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! if (job%IOmatelem_split.and..not.job%vib_rot_contr) then ! - call divided_slice_read(islice,'g_cor',job%matelem_suffix,dimen,gmat,gmat_block_type,ierror) + call divided_slice_read(islice,'g_cor',job%matelem_suffix,dimen,gmat,desc_gmat,gmat_block_type,ierror) ! elseif (job%IOmatelem_split.and.job%vib_rot_contr) then ! @@ -2072,7 +2072,7 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! if (job%IOextF_divide) then ! - call divided_slice_read(imu,'extF',job%extmat_suffix,dimen,extF_me,extF_block_type,ierror) + call divided_slice_read(imu,'extF',job%extmat_suffix,dimen,extF_me,desc_extF,extF_block_type,ierror) ! if (ierror==1) cycle ! @@ -2341,13 +2341,14 @@ subroutine divided_slice_write_mpi(islice,name,suffix,N,field,block_type) end subroutine divided_slice_write_mpi ! ! - subroutine divided_slice_read(islice,name,suffix,N,field,block_type,ierror) + subroutine divided_slice_read(islice,name,suffix,N,field,field_descr,block_type,ierror) ! implicit none ! integer(ik),intent(in) :: islice character(len=*),intent(in) :: name,suffix integer(ik),intent(in) :: N + integer, intent(in) :: field_descr(9) type(MPI_Datatype),intent(in) :: block_type real(rk),intent(out) :: field(N,N) integer(ik),intent(out) :: ierror @@ -2387,7 +2388,7 @@ subroutine divided_slice_read(islice,name,suffix,N,field,block_type,ierror) stop 'divided_slice_read - in slice - header missing or wrong' end if ! - call ioHandler%read(field, extF_block_type) + call ioHandler%read(field, field_descr, block_type) ! call ioHandler%read(buf(1:ilen)) if ( trim(buf(1:ilen))/=trim(name) ) then From 55af7d62bdde71c4a45c44e8bc78b4cd56278965 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Tue, 19 Oct 2021 17:57:43 +0100 Subject: [PATCH 06/66] Refactor MPI writer to not use manual offset counting --- io_handler_mpi.f90 | 85 ++++++++++++++++++---------------- test/unit/test_mpi_io.pf | 99 +++++++++++++++++++++++++++------------- 2 files changed, 113 insertions(+), 71 deletions(-) diff --git a/io_handler_mpi.f90 b/io_handler_mpi.f90 index d83c7ad..2d8c36a 100644 --- a/io_handler_mpi.f90 +++ b/io_handler_mpi.f90 @@ -113,13 +113,15 @@ subroutine open(this, fname, err, action, position, status, form, access) accessVal = 'sequential' end if - print *, "MPI: Opening ", trim(fname), " with ", \ - trim(action), " ", 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) + if(this%rank == 0) then + print *, "MPI: Opening ", trim(fname), " with ", \ + trim(action), " ", trim(positionVal), " ", trim(statusVal), " ", trim(formVal), " ", trim(accessVal) + endif + ! 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) @@ -181,7 +183,6 @@ subroutine writeScalarMPI(this, object) type(MPI_Datatype) :: mpiType call getMPIVarInfo(object, byteSize, mpiType) - this%offset = this%offset + 4+byteSize+4 select type(object) type is (character(len=*)) @@ -190,15 +191,15 @@ subroutine writeScalarMPI(this, object) length = 1 end select - if (this%rank /= 0) then - return + if (this%rank == 0) then + call MPI_File_write(this%fileh, byteSize, 1, MPI_INTEGER, & + MPI_STATUS_IGNORE, ierr) + 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) + else + call MPI_File_seek(this%fileh, int(4+byteSize+4,MPI_OFFSET_KIND), MPI_SEEK_CUR, ierr) end if - - call MPI_File_write(this%fileh, byteSize, 1, MPI_INTEGER, & - MPI_STATUS_IGNORE, ierr) - 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) end subroutine subroutine write1DArrayMPI(this, object) @@ -221,18 +222,15 @@ subroutine write2DArrayMPI(this, object) call getMPIVarInfo(object(1,1), byteSize, mpiType) arrSizeBytes = globalSize*byteSize - this%offset = this%offset + 4 + arrSizeBytes + 4 - - if (this%rank /= 0) then - call MPI_File_seek(this%fileh, this%offset, MPI_SEEK_SET, ierr) - return + if (this%rank == 0) then + call MPI_File_write(this%fileh, arrSizeBytes, 1, MPI_INTEGER, & + MPI_STATUS_IGNORE, ierr) + 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) + else + call MPI_File_seek(this%fileh, int(4+arrSizeBytes+4,MPI_OFFSET_KIND), MPI_SEEK_CUR, ierr) end if - - call MPI_File_write(this%fileh, arrSizeBytes, 1, MPI_INTEGER, & - MPI_STATUS_IGNORE, ierr) - 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) end subroutine subroutine write2DArrayDistBlacsMPI(this, object, descr, block_type) @@ -244,6 +242,7 @@ subroutine write2DArrayDistBlacsMPI(this, object, descr, block_type) type(MPI_Datatype) :: mpiType integer :: byteSize, globalSize, ierr integer(kind = MPI_OFFSET_KIND) :: arrSizeBytes + integer(kind = MPI_OFFSET_KIND) :: offset, disp integer :: dims(2) @@ -253,6 +252,10 @@ subroutine write2DArrayDistBlacsMPI(this, object, descr, block_type) call getMPIVarInfo(object(1,1), byteSize, mpiType) arrSizeBytes = globalSize*byteSize + call MPI_File_get_position(this%fileh, offset, ierr) + ! Get initial displacement in file + call MPI_File_get_byte_offset(this%fileh, offset, disp, ierr) + 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, & @@ -261,17 +264,14 @@ subroutine write2DArrayDistBlacsMPI(this, object, descr, block_type) 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, & + + ! Set file view including offsetting bookend + call MPI_File_set_view(this%fileh, disp+4, mpiType, block_type, & 'native', MPI_INFO_NULL, ierr) ! Write array in parallel 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 - ! Reset file view back to regular ol bytes - call MPI_File_set_view(this%fileh, this%offset, MPI_BYTE, MPI_BYTE, & + ! Reset file view + call MPI_File_set_view(this%fileh, disp+4+arrSizeBytes+4, MPI_BYTE, MPI_BYTE, & 'native', MPI_INFO_NULL, ierr) end subroutine @@ -283,12 +283,18 @@ subroutine write2DArrayDistColumnMPI(this, object, mdimen) type(MPI_Datatype) :: mpiType integer :: byteSize, globalSize, ierr, writestat integer(kind = MPI_OFFSET_KIND) :: arrSizeBytes + integer(kind = MPI_OFFSET_KIND) :: offset, disp globalSize = mdimen**2 call getMPIVarInfo(object(1,1), byteSize, mpiType) arrSizeBytes = globalSize*byteSize + ! Get individual pointer offset + call MPI_File_get_position(this%fileh, offset, ierr) + ! Get initial displacement in file + call MPI_File_get_byte_offset(this%fileh, offset, disp, ierr) + ! TODO what if format isn't sequential?? if (this%rank == 0) then ! write first and last bookends containing array size in bytes @@ -298,16 +304,17 @@ subroutine write2DArrayDistColumnMPI(this, object, mdimen) 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) + + ! Set shared pointer to individual pointer + bookend + call MPI_File_seek_shared(this%fileh, offset+4, MPI_SEEK_SET, ierr) ! Write array in parallel 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 - call MPI_File_seek(this%fileh, this%offset, MPI_SEEK_SET, ierr) + ! Skip over last bookend + call MPI_File_seek_shared(this%fileh, int(4,MPI_OFFSET_KIND), MPI_SEEK_CUR, ierr) + + ! Set individual pointer to match shared + call MPI_File_get_position_shared(this%fileh, offset, ierr) + call MPI_File_seek(this%fileh, offset, MPI_SEEK_SET, ierr) end subroutine subroutine readScalarMPI(this, object) diff --git a/test/unit/test_mpi_io.pf b/test/unit/test_mpi_io.pf index 6203432..7529453 100644 --- a/test/unit/test_mpi_io.pf +++ b/test/unit/test_mpi_io.pf @@ -21,7 +21,7 @@ module test_mpi_io integer,external :: INDXL2G logical :: is_mpi_initialised = .false. - integer, parameter :: totalTestCount = 4 ! CHANGE ME TO NUMBER OF TESTS + integer, parameter :: totalTestCount = 5 ! CHANGE ME TO NUMBER OF TESTS integer :: currentTestCount = 0 contains @@ -43,7 +43,70 @@ module test_mpi_io end subroutine tearDown @test - subroutine testMPIWriting(this) + subroutine testMPIWritingScalars(this) + class(TestMPI), intent(inout) :: this + + type(ioHandlerMPI) :: ioHandler + + 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" + character(len=*), parameter :: position = "asis" + character(len=*), parameter :: status = "unknown" + character(len=*), parameter :: form = "unformatted" + character(len=*), parameter :: access = "sequential" + + type(ErrorType) :: err + + integer :: ierr, rank, allocinfo = 0 + + ! Set up MPI + call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr) + if(ierr.ne.0) print *, "Error: could not get rank" + + ! Write + call ioHandler%open(fname, err, action='write', & + form=form, access=access, status=status, position=position) + HANDLE_ERROR(err) + + ! Test writing scalars + call ioHandler%write(true_integer) ! int + call ioHandler%write(true_real) ! double + call ioHandler%write(true_complex) ! complex + call ioHandler%write(true_str) ! string + + call ioHandler%close() + + ! 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) + + read(iounit) in_real + @assertTrue(in_real == true_real) + + read(iounit) in_complex + @assertTrue(in_complex == true_complex) + + read(iounit) in_str + @assertTrue(in_str == true_str) + + ! Remove test file + if (stat == 0) close(iounit, status='delete') + + endif + + end subroutine + + @test + subroutine testMPIWritingBlacsDistArray(this) class(TestMPI), intent(inout) :: this type(ioHandlerMPI) :: ioHandler @@ -55,10 +118,7 @@ module test_mpi_io integer :: array2D_descr(9) = 0 type(MPI_Datatype) :: array2D_block_type - 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" @@ -100,12 +160,6 @@ module test_mpi_io form=form, access=access, status=status, position=position) HANDLE_ERROR(err) - ! Test writing scalars - call ioHandler%write(true_integer) ! int - call ioHandler%write(true_real) ! double - call ioHandler%write(true_complex) ! complex - call ioHandler%write(true_str) ! string - ! Test writing an array call ioHandler%write(array2D, array2D_descr, array2D_block_type) @@ -115,9 +169,6 @@ module test_mpi_io ! Test writing another array call ioHandler%write(array2D, array2D_descr, array2D_block_type) - ! Test writing something after 2nd array - call ioHandler%write(true_integer) - call ioHandler%close() ! Only test result on main process @@ -125,19 +176,6 @@ module test_mpi_io 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) - - read(iounit) in_real - @assertTrue(in_real == true_real) - - 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 @@ -155,15 +193,12 @@ 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 - end subroutine testMPIWriting + end subroutine @test subroutine testMPIWritingColumnDistArray(this) @@ -344,7 +379,7 @@ module test_mpi_io end subroutine @test - subroutine testMPIReadBlasDistArray(this) + subroutine testMPIReadBlacsDistArray(this) class(TestMPI), intent(inout) :: this type(ioHandlerMPI) :: ioHandler From 344ce55006bee50aa894cc70d0ff5b3e5d5a12a1 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Tue, 19 Oct 2021 18:04:44 +0100 Subject: [PATCH 07/66] Properly reset file view --- io_handler_mpi.f90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/io_handler_mpi.f90 b/io_handler_mpi.f90 index 2d8c36a..69b549e 100644 --- a/io_handler_mpi.f90 +++ b/io_handler_mpi.f90 @@ -271,8 +271,9 @@ subroutine write2DArrayDistBlacsMPI(this, object, descr, block_type) ! Write array in parallel MPI_WRAPPER(MPI_File_write_all, this%fileh, object, size(object), mpiType, MPI_STATUS_IGNORE, ierr) ! Reset file view - call MPI_File_set_view(this%fileh, disp+4+arrSizeBytes+4, MPI_BYTE, MPI_BYTE, & + call MPI_File_set_view(this%fileh, int(0,MPI_OFFSET_KIND), MPI_BYTE, MPI_BYTE, & 'native', MPI_INFO_NULL, ierr) + call MPI_File_seek(this%fileh, disp+4+arrSizeBytes+4, MPI_SEEK_SET) end subroutine subroutine write2DArrayDistColumnMPI(this, object, mdimen) @@ -379,8 +380,9 @@ subroutine read2DArrayDistBlacsMPI(this, object, descr, block_type) ! Read array in parallel MPI_WRAPPER(MPI_File_read_all, this%fileh, object, size(object), mpiType, MPI_STATUS_IGNORE, ierr) ! Reset file view back to regular ol bytes, including bookends and array we've just written - call MPI_File_set_view(this%fileh, disp+4+arrSizeBytes+4, MPI_BYTE, MPI_BYTE, & + call MPI_File_set_view(this%fileh, int(0,MPI_OFFSET_KIND), MPI_BYTE, MPI_BYTE, & 'native', MPI_INFO_NULL, ierr) + call MPI_File_seek(this%fileh, disp+4+arrSizeBytes+4, MPI_SEEK_SET) end subroutine end module From 73ff373af6178bf8d7b6434bfd62f7635eb4ba6d Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Tue, 19 Oct 2021 18:05:01 +0100 Subject: [PATCH 08/66] Remove MPI version of divided_slice_read --- tran.f90 | 73 -------------------------------------------------------- 1 file changed, 73 deletions(-) diff --git a/tran.f90 b/tran.f90 index c99e543..50c7b43 100644 --- a/tran.f90 +++ b/tran.f90 @@ -2416,79 +2416,6 @@ subroutine divided_slice_read(islice,name,suffix,N,field,field_descr,block_type, end subroutine divided_slice_read ! ! - subroutine divided_slice_read_mpi(islice,name,suffix,N,field,block_type,ierr) - ! - implicit none - ! - integer(ik),intent(in) :: islice - character(len=*),intent(in) :: name,suffix - integer(ik),intent(in) :: N - real(rk),dimension(:,:),intent(out) :: field - type(MPI_Datatype),intent(in) :: block_type - integer(ik),intent(out) :: ierr -#ifdef TROVE_USE_MPI_ - character(len=4) :: jchar - type(MPI_File) :: chkptMPIIO - character(len=cl) :: buf,filename,job_is - integer(ik) :: ilen - integer(MPI_OFFSET_KIND) :: offset - ! - ierror = 0 - ! - write(job_is,"('single swap_matrix MPI')") - ! - write(jchar, '(i4)') islice - ! - filename = trim(suffix)//trim(adjustl(jchar))//'.chk' - ilen = LEN_TRIM(name) - ! - call MPI_File_open(mpi_comm_world, filename, mpi_mode_rdonly, mpi_info_null, chkptMPIIO, ierr) - ! - if (ierr .ne. 0) then - ! - ! This error code will allow simply skipping the corresponding record/file without crashing the program - ! - ierr = 1 - ! - ! we allow to skip opening the file only for the external matrix elements - ! - if (trim(name)/="extF") then - write (out,"(' kinetic divided_slice_read_mpi in slice ',a20,': file does not exist')") filename - stop 'divided_slice_read_mpi - in slice - file does not exist' - endif - ! - if (job%verbose>=4) write (out,"(' (skipped).')",advance='YES') - ! - return - endif - ! - call MPI_File_read_all(chkptMPIIO,buf,ilen,mpi_character,mpi_status_ignore,ierr) - ! - if ( trim(buf(1:ilen))/=trim(name) ) then - write (out,"(' kinetic divided_slice_read_mpi in slice ',a20,': header is missing or wrong: ',a)") filename,buf(1:ilen) - stop 'divided_slice_read_mpi - in slice - header missing or wrong' - end if - ! - offset = ilen - call MPI_File_set_view(chkptMPIIO, int(ilen,MPI_OFFSET_KIND), mpi_byte, block_type, "native", MPI_INFO_NULL, ierr) - call MPI_File_read_all(chkptMPIIO, field, size(field), mpi_double_precision, mpi_status_ignore, ierr) - ! - offset = offset + N*int(N,MPI_OFFSET_KIND)*mpi_real_size - call MPI_File_set_view(chkptMPIIO, offset, mpi_byte, mpi_byte, "native", MPI_INFO_NULL, ierr) - ! - call MPI_File_read_all(chkptMPIIO,buf,ilen,mpi_character,mpi_status_ignore,ierr) - ! - if ( trim(buf(1:ilen))/=trim(name) ) then - write (out,"(' kinetic divided_slice_read_mpi in slice ',a20,': header is missing or wrong',a)") filename,buf(1:ilen) - stop 'divided_slice_read_mpi - in slice - header missing or wrong' - end if - ! - call MPI_File_close(chkptMPIIO, ierr) - ! -#endif - end subroutine divided_slice_read_mpi - ! - ! subroutine divided_slice_read_vibrot(islice,suffix,N,field) ! implicit none From ffa1ea924e9082b1757fd31dbcadc068e9ffa300 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Tue, 19 Oct 2021 18:11:59 +0100 Subject: [PATCH 09/66] Better align file opening lines to see read/write and type of io handler when grepping --- perturbation.f90 | 21 +++++++++------------ 1 file changed, 9 insertions(+), 12 deletions(-) diff --git a/perturbation.f90 b/perturbation.f90 index 00cd53b..49921a1 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -16286,14 +16286,12 @@ subroutine PTcontracted_matelem_class(jrot) ! #ifdef TROVE_USE_MPI_ allocate(ioHandler, & - source=ioHandlerMPI(& - job%kinetmat_file, err, & - action='write', position='rewind', status='replace', form='unformatted')) + 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')) + source=ioHandlerFTN(job%kinetmat_file, err, action='write', & + position='rewind', status='replace', form='unformatted')) #endif HANDLE_ERROR(err) @@ -17936,10 +17934,10 @@ subroutine PTcontracted_matelem_class_fast_II(jrot) job_is ='Vib. matrix elements of the rot. kinetic part' call IOStart(trim(job_is),chkptIO) + ! TODO should this just be fortran writer? allocate(ioHandler, & - source=ioHandlerFTN(& - job%kinetmat_file, err, & - action='write', position='rewind', status='replace', form='unformatted')) + source=ioHandlerFTN(job%kinetmat_file, err, action='write', & + position='rewind', status='replace', form='unformatted')) HANDLE_ERROR(err) call ioHandler%write('Start Kinetic part') ! @@ -38357,9 +38355,8 @@ subroutine PTcontracted_matelem_class_fast(jrot) call IOStart(trim(job_is),chkptIO) ! allocate(ioHandler, & - source=ioHandlerFTN(& - job%kinetmat_file, err, & - action='write', position='rewind', status='replace', form='unformatted')) + source=ioHandlerFTN(job%kinetmat_file, err, action='write',& + position='rewind', status='replace', form='unformatted')) HANDLE_ERROR(err) call ioHandler%write('Start Kinetic part') From 8d64a509287bfb759ef779e74ec6b74d0c9dad67 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Tue, 19 Oct 2021 18:35:20 +0100 Subject: [PATCH 10/66] Refector for clarity --- tran.f90 | 21 +++++---------------- 1 file changed, 5 insertions(+), 16 deletions(-) diff --git a/tran.f90 b/tran.f90 index 50c7b43..164d5f4 100644 --- a/tran.f90 +++ b/tran.f90 @@ -1673,25 +1673,14 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! if (job%verbose>=3) write(out,"(/' Transform grot to J0-repres...')") ! - if (.not.job%IOmatelem_split) then - ! + if (job%IOmatelem_split) then + task = 'top' + else task = 'rot' - ! call ioHandler%write('g_rot') - ! - call restore_rot_kinetic_matrix_elements(jrot,treat_vibration,task,iunit) - ! - else - ! - task = 'top' - ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - call restore_rot_kinetic_matrix_elements_mpi(jrot,treat_vibration,task,fileh) - else - call restore_rot_kinetic_matrix_elements(jrot,treat_vibration,task,iunit) - endif - ! endif + + call restore_rot_kinetic_matrix_elements(jrot,treat_vibration,task) ! if (job%verbose>=5) call TimerStart('J0-convertion for g_rot') ! From d2fcec545d743ca093703468a91844fc24fa32d3 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 21 Oct 2021 12:22:12 +0100 Subject: [PATCH 11/66] Refactor bookend byte handling & implement direct access --- io_handler_mpi.f90 | 154 ++++++++++++++++++++++++++++----------------- 1 file changed, 97 insertions(+), 57 deletions(-) diff --git a/io_handler_mpi.f90 b/io_handler_mpi.f90 index 69b549e..6ece336 100644 --- a/io_handler_mpi.f90 +++ b/io_handler_mpi.f90 @@ -31,10 +31,11 @@ module io_handler_mpi implicit none type, extends(ioHandlerBase) :: ioHandlerMPI - integer (kind=MPI_Offset_kind) :: offset = 0 - integer :: rank = 0 + integer (kind=MPI_Offset_kind) :: bookendBytes + integer :: rank = -1 type(MPI_File) :: fileh logical :: isOpen = .false. + character (len=20) :: accessVal contains procedure :: writeScalar => writeScalarMPI procedure :: write1DArray => write1DArrayMPI @@ -45,6 +46,7 @@ module io_handler_mpi procedure :: read1DArray => read1DArrayMPI procedure :: read2DArray => read2DArrayMPI procedure :: read2DArrayDistBlacs => read2DArrayDistBlacsMPI + procedure :: read2DArrayDistColumn => read2DArrayDistColumnMPI procedure :: open procedure :: close final :: destroyIoHandlerMPI @@ -82,7 +84,7 @@ subroutine open(this, fname, err, action, position, status, form, access) 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 + character (len = 20) :: positionVal, statusVal, formVal integer :: ierr if (this%isOpen) then @@ -108,10 +110,16 @@ subroutine open(this, fname, err, action, position, status, form, access) end if if (present(access)) then - accessVal = access + this%accessVal = access else - accessVal = 'sequential' - end if + this%accessVal = 'sequential' + endif + + if (trim(this%accessVal) == "sequential") then + this%bookendBytes = 4 + else + this%bookendBytes = 0 + endif ! FIXME use above flags to change open behaviour @@ -119,7 +127,7 @@ subroutine open(this, fname, err, action, position, status, form, access) if(this%rank == 0) then print *, "MPI: Opening ", trim(fname), " with ", \ - trim(action), " ", trim(positionVal), " ", trim(statusVal), " ", trim(formVal), " ", trim(accessVal) + trim(action), " ", trim(positionVal), " ", trim(statusVal), " ", trim(formVal), " ", trim(this%accessVal) endif ! FIXME is there a better way to set MPI_MODE_* flags? @@ -175,12 +183,37 @@ subroutine getMPIVarInfo(object, byteSize, mpiType) end select end subroutine + subroutine writeBookendBytes(this, bytes) + ! write first and last bookends containing object size in bytes + + class(ioHandlerMPI) :: this + integer :: bytes, ierr + integer(kind=MPI_OFFSET_KIND) :: offset + + if (this%rank == 0 .and. trim(this%accessVal)=="sequential") then + ! Get original position + call MPI_File_get_position(this%fileh, offset, ierr) + + ! Write bookends + call MPI_File_write(this%fileh, bytes, 1, MPI_INTEGER, & + MPI_STATUS_IGNORE, ierr) + call MPI_File_seek(this%fileh, int(bytes,MPI_OFFSET_KIND), MPI_SEEK_CUR, ierr) + call MPI_File_write(this%fileh, bytes, 1, MPI_INTEGER, & + MPI_STATUS_IGNORE, ierr) + + ! Reset position + call MPI_File_seek(this%fileh, offset, MPI_SEEK_SET, ierr) + endif + end subroutine + + subroutine writeScalarMPI(this, object) class(ioHandlerMPI) :: this class(*), intent(in) :: object integer :: byteSize, ierr, length type(MPI_Datatype) :: mpiType + integer(kind = MPI_OFFSET_KIND) :: offset call getMPIVarInfo(object, byteSize, mpiType) @@ -191,21 +224,21 @@ subroutine writeScalarMPI(this, object) length = 1 end select + call writeBookendBytes(this, byteSize) + + call MPI_File_seek(this%fileh, this%bookendBytes, MPI_SEEK_CUR, ierr) if (this%rank == 0) then - call MPI_File_write(this%fileh, byteSize, 1, MPI_INTEGER, & - MPI_STATUS_IGNORE, ierr) 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) else - call MPI_File_seek(this%fileh, int(4+byteSize+4,MPI_OFFSET_KIND), MPI_SEEK_CUR, ierr) + call MPI_File_seek(this%fileh, int(byteSize,kind=MPI_OFFSET_KIND), MPI_SEEK_CUR, ierr) end if + call MPI_File_seek(this%fileh, this%bookendBytes, MPI_SEEK_CUR, ierr) end subroutine subroutine write1DArrayMPI(this, object) class(ioHandlerMPI) :: this class(*), intent(in) :: object(:) - print *, "ERROR: 1D array saving not currently supported" + stop "ERROR: 1D array saving not currently supported by MPI writer" end subroutine subroutine write2DArrayMPI(this, object) @@ -213,24 +246,24 @@ subroutine write2DArrayMPI(this, object) class(*), intent(in) :: object(:,:) type(MPI_Datatype) :: mpiType - integer :: byteSize, globalSize, ierr, length + integer :: byteSize, globalSize, ierr, length, arrSizeBytes - integer(kind = MPI_OFFSET_KIND) :: arrSizeBytes + integer(kind = MPI_OFFSET_KIND) :: offset globalSize = size(object) call getMPIVarInfo(object(1,1), byteSize, mpiType) arrSizeBytes = globalSize*byteSize + call writeBookendBytes(this, arrSizeBytes) + + call MPI_File_seek(this%fileh, this%bookendBytes, MPI_SEEK_CUR, ierr) if (this%rank == 0) then - call MPI_File_write(this%fileh, arrSizeBytes, 1, MPI_INTEGER, & - MPI_STATUS_IGNORE, ierr) 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) else - call MPI_File_seek(this%fileh, int(4+arrSizeBytes+4,MPI_OFFSET_KIND), MPI_SEEK_CUR, ierr) + call MPI_File_seek(this%fileh, int(arrSizeBytes,kind=MPI_OFFSET_KIND), MPI_SEEK_CUR, ierr) end if + call MPI_File_seek(this%fileh, this%bookendBytes, MPI_SEEK_CUR, ierr) end subroutine subroutine write2DArrayDistBlacsMPI(this, object, descr, block_type) @@ -240,8 +273,7 @@ subroutine write2DArrayDistBlacsMPI(this, object, descr, block_type) 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 :: byteSize, arrSizeBytes, globalSize, ierr integer(kind = MPI_OFFSET_KIND) :: offset, disp integer :: dims(2) @@ -252,28 +284,21 @@ subroutine write2DArrayDistBlacsMPI(this, object, descr, block_type) call getMPIVarInfo(object(1,1), byteSize, mpiType) arrSizeBytes = globalSize*byteSize + call writeBookendBytes(this, arrSizeBytes) + call MPI_File_get_position(this%fileh, offset, ierr) ! Get initial displacement in file call MPI_File_get_byte_offset(this%fileh, offset, disp, ierr) - 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 - ! Set file view including offsetting bookend - call MPI_File_set_view(this%fileh, disp+4, mpiType, block_type, & + call MPI_File_set_view(this%fileh, disp+this%bookendBytes, mpiType, block_type, & 'native', MPI_INFO_NULL, ierr) ! Write array in parallel MPI_WRAPPER(MPI_File_write_all, this%fileh, object, size(object), mpiType, MPI_STATUS_IGNORE, ierr) ! Reset file view call MPI_File_set_view(this%fileh, int(0,MPI_OFFSET_KIND), MPI_BYTE, MPI_BYTE, & 'native', MPI_INFO_NULL, ierr) - call MPI_File_seek(this%fileh, disp+4+arrSizeBytes+4, MPI_SEEK_SET) + call MPI_File_seek(this%fileh, disp+this%bookendBytes+arrSizeBytes+this%bookendBytes, MPI_SEEK_SET) end subroutine subroutine write2DArrayDistColumnMPI(this, object, mdimen) @@ -282,8 +307,7 @@ subroutine write2DArrayDistColumnMPI(this, object, mdimen) integer, intent(in) :: mdimen ! Dimension of entire distributed array type(MPI_Datatype) :: mpiType - integer :: byteSize, globalSize, ierr, writestat - integer(kind = MPI_OFFSET_KIND) :: arrSizeBytes + integer :: byteSize, globalSize, ierr, writestat, arrSizeBytes integer(kind = MPI_OFFSET_KIND) :: offset, disp globalSize = mdimen**2 @@ -291,27 +315,16 @@ subroutine write2DArrayDistColumnMPI(this, object, mdimen) call getMPIVarInfo(object(1,1), byteSize, mpiType) arrSizeBytes = globalSize*byteSize + call writeBookendBytes(this, arrSizeBytes) + ! Get individual pointer offset call MPI_File_get_position(this%fileh, offset, ierr) - ! Get initial displacement in file - call MPI_File_get_byte_offset(this%fileh, offset, disp, ierr) - - ! 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 - ! Set shared pointer to individual pointer + bookend - call MPI_File_seek_shared(this%fileh, offset+4, MPI_SEEK_SET, ierr) + call MPI_File_seek_shared(this%fileh, offset+this%bookendBytes, MPI_SEEK_SET, ierr) ! Write array in parallel MPI_WRAPPER(MPI_File_write_ordered,this%fileh,object,1,mpitype_column,MPI_STATUS_IGNORE,ierr) ! Skip over last bookend - call MPI_File_seek_shared(this%fileh, int(4,MPI_OFFSET_KIND), MPI_SEEK_CUR, ierr) + call MPI_File_seek_shared(this%fileh, int(this%bookendBytes,MPI_OFFSET_KIND), MPI_SEEK_CUR, ierr) ! Set individual pointer to match shared call MPI_File_get_position_shared(this%fileh, offset, ierr) @@ -323,7 +336,6 @@ subroutine readScalarMPI(this, object) class(*), intent(out) :: object integer :: byteSize, ierr, length - integer(kind = MPI_OFFSET_KIND) :: offset type(MPI_Datatype) :: mpiType call getMPIVarInfo(object, byteSize, mpiType) @@ -335,9 +347,9 @@ subroutine readScalarMPI(this, object) length = 1 end select - call MPI_File_seek(this%fileh, int(4,MPI_OFFSET_KIND), MPI_SEEK_CUR, ierr) + call MPI_File_seek(this%fileh, int(this%bookendBytes,MPI_OFFSET_KIND), MPI_SEEK_CUR, ierr) MPI_WRAPPER(MPI_File_read_all, this%fileh, object, length, mpiType, MPI_STATUS_IGNORE, ierr) - call MPI_File_seek(this%fileh, int(4,MPI_OFFSET_KIND), MPI_SEEK_CUR, ierr) + call MPI_File_seek(this%fileh, int(this%bookendBytes,MPI_OFFSET_KIND), MPI_SEEK_CUR, ierr) end subroutine subroutine read1DArrayMPI(this, object) @@ -363,8 +375,6 @@ subroutine read2DArrayDistBlacsMPI(this, object, descr, block_type) integer :: dims(2) - call getMPIVarInfo(object(1,1), byteSize, mpiType) - dims(:) = descr(3:4) globalSize = dims(1)*dims(2) @@ -375,14 +385,44 @@ subroutine read2DArrayDistBlacsMPI(this, object, descr, block_type) ! Get initial displacement in file call MPI_File_get_byte_offset(this%fileh, offset, disp, ierr) ! Set file view including offsetting bookend - call MPI_File_set_view(this%fileh, offset+4, mpiType, block_type, & + call MPI_File_set_view(this%fileh, disp+this%bookendBytes, mpiType, block_type, & 'native', MPI_INFO_NULL, ierr) ! Read array in parallel MPI_WRAPPER(MPI_File_read_all, this%fileh, object, size(object), mpiType, MPI_STATUS_IGNORE, ierr) ! Reset file view back to regular ol bytes, including bookends and array we've just written call MPI_File_set_view(this%fileh, int(0,MPI_OFFSET_KIND), MPI_BYTE, MPI_BYTE, & 'native', MPI_INFO_NULL, ierr) - call MPI_File_seek(this%fileh, disp+4+arrSizeBytes+4, MPI_SEEK_SET) + call MPI_File_seek(this%fileh, disp+this%bookendBytes+arrSizeBytes+this%bookendBytes, MPI_SEEK_SET) + end subroutine + + subroutine read2DArrayDistColumnMPI(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, arrSizeBytes + integer(kind = MPI_OFFSET_KIND) :: offset, disp + + globalSize = mdimen**2 + + call getMPIVarInfo(object(1,1), byteSize, mpiType) + arrSizeBytes = globalSize*byteSize + + call writeBookendBytes(this, arrSizeBytes) + + ! Get individual pointer offset + call MPI_File_get_position(this%fileh, offset, ierr) + ! Set shared pointer to individual pointer + bookend + call MPI_File_seek_shared(this%fileh, offset+this%bookendBytes, MPI_SEEK_SET, ierr) + ! Write array in parallel + MPI_WRAPPER(MPI_File_read_ordered,this%fileh,object,1,mpitype_column,MPI_STATUS_IGNORE,ierr) + ! Skip over last bookend + call MPI_File_seek_shared(this%fileh, int(this%bookendBytes,MPI_OFFSET_KIND), MPI_SEEK_CUR, ierr) + + ! Set individual pointer to match shared + call MPI_File_get_position_shared(this%fileh, offset, ierr) + call MPI_File_seek(this%fileh, offset, MPI_SEEK_SET, ierr) end subroutine end module From 046257868b04725284a052efa0e564453d7c0dbf Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 21 Oct 2021 12:22:39 +0100 Subject: [PATCH 12/66] Implement MPI IO for everything except ext field --- tran.f90 | 537 +++++++++---------------------------------------------- 1 file changed, 86 insertions(+), 451 deletions(-) diff --git a/tran.f90 b/tran.f90 index 164d5f4..6b28dc1 100644 --- a/tran.f90 +++ b/tran.f90 @@ -1615,14 +1615,12 @@ 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')) + 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')) + source=ioHandlerFTN(job%kineteigen_file, err, action='write', & + position='rewind', status='replace', form='unformatted')) #endif HANDLE_ERROR(err) call ioHandler%write('Start Kinetic part') @@ -1664,10 +1662,6 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! endif ! - -#ifdef TROVE_USE_MPI_ - call MPI_File_open(mpi_comm_world, job%kinetmat_file, mpi_mode_rdonly, mpi_info_null, fileh, ierr) -#endif ! The eigen-vibrational (J=0) matrix elements of the rotational and coriolis ! kinetic parts are being computed here. ! @@ -1688,13 +1682,6 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! islice = 0 ! - if ((.not.job%IOmatelem_split) .and. blacs_size.gt.1) then -#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) -#endif - endif - ! do k1 = 1,3 ! do k2 = 1,3 @@ -1709,17 +1696,11 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! elseif (job%IOmatelem_split.and.job%vib_rot_contr) then ! - call divided_slice_read_vibrot(islice,job%matelem_suffix,dimen,gmat) + call divided_slice_read_vibrot(islice,job%matelem_suffix,dimen,gmat,desc_gmat,gmat_block_type) ! else ! - if (trim(job%kinetmat_format).eq.'MPIIO') then -#ifdef TROVE_USE_MPI_ - call MPI_File_read_all(fileh, gmat, size(gmat), mpi_double_precision, mpi_status_ignore, ierr) -#endif - else - read(iunit) gmat - endif + call ioHandler%read(gmat, desc_gmat, gmat_block_type) ! endif ! @@ -1740,15 +1721,11 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! if (job%IOmatelem_split.and..not.job%vib_rot_contr) then ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - call divided_slice_write_mpi(islice,'g_rot',job%j0matelem_suffix,Neigenroots,mat_s,mat_s_block_type) - else - if(mpi_rank.eq.0) call divided_slice_write(islice,'g_rot',job%j0matelem_suffix,Neigenroots,mat_s) - endif + call divided_slice_write(islice,'g_rot',job%j0matelem_suffix,Neigenroots,mat_s, desc_mat_s,mat_s_block_type) ! elseif (job%IOmatelem_split.and.job%vib_rot_contr) then ! - if(mpi_rank.eq.0) call divided_slice_write_vibrot(islice,job%j0matelem_suffix,Neigenroots,mat_s) + call divided_slice_write_vibrot(islice,job%j0matelem_suffix,Neigenroots,mat_s,desc_mat_s,mat_s_block_type) ! else ! @@ -1778,16 +1755,7 @@ subroutine TRconvert_matel_j0_eigen(jrot) if (.not.job%IOmatelem_split) then ! task = 'cor' - if (trim(job%kinetmat_format).eq.'MPIIO') then - ! -#ifdef TROVE_USE_MPI_ - call restore_rot_kinetic_matrix_elements_mpi(jrot,treat_vibration,task,fileh) - ! - 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) - endif + call restore_rot_kinetic_matrix_elements(jrot,treat_vibration,task) call ioHandler%write('g_cor') ! endif @@ -1798,13 +1766,6 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! islice = 9 ! - if ((.not.job%IOmatelem_split) .and. blacs_size.gt.1) then -#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) -#endif - endif - ! !do k1 = 1,FLNmodes ! !if (job%contrci_me_fast.and.k1>1) cycle @@ -1821,17 +1782,11 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! elseif (job%IOmatelem_split.and.job%vib_rot_contr) then ! - call divided_slice_read_vibrot(islice,job%matelem_suffix,dimen,gmat) + call divided_slice_read_vibrot(islice,job%matelem_suffix,dimen,gmat,desc_gmat,gmat_block_type) ! else ! - if (trim(job%kinetmat_format).eq.'MPIIO') then -#ifdef TROVE_USE_MPI_ - call MPI_File_read_all(fileh, gmat, size(gmat), mpi_double_precision, mpi_status_ignore, ierr) -#endif - else - read(iunit) gmat - endif + call ioHandler%read(gmat,desc_gmat,gmat_block_type) ! endif ! @@ -1850,54 +1805,29 @@ subroutine TRconvert_matel_j0_eigen(jrot) endif ! ! - if (job%IOmatelem_split.and..not.job%vib_rot_contr) then - ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - call divided_slice_write_mpi(islice,'g_cor',job%j0matelem_suffix,Neigenroots,mat_s,mat_s_block_type) + if (job%IOmatelem_split) then + if(job%vib_rot_contr) then + call divided_slice_write_vibrot(islice,job%j0matelem_suffix,Neigenroots,mat_s,desc_mat_s,mat_s_block_type) else - if(mpi_rank.eq.0) call divided_slice_write(islice,'g_cor',job%j0matelem_suffix,Neigenroots,mat_s) + call divided_slice_write(islice,'g_cor',job%j0matelem_suffix,Neigenroots,mat_s,desc_mat_s,mat_s_block_type) endif - ! - elseif (job%IOmatelem_split.and.job%vib_rot_contr) then - ! - if(mpi_rank.eq.0) call divided_slice_write_vibrot(islice,job%j0matelem_suffix,Neigenroots,mat_s) - ! else - ! call ioHandler%write(mat_s, desc_mat_s, mat_s_block_type) - ! endif ! enddo ! !enddo ! - ! Reset view to flat file - if ((.not.job%IOmatelem_split) .and. blacs_size.gt.1) then -#ifdef TROVE_USE_MPI_ - 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) -#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 call ioHandler%write('End Kinetic part') endif ! - if (.not.job%vib_rot_contr) then - deallocate(ioHandler) - endif - ! task = 'end' ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - call restore_rot_kinetic_matrix_elements_mpi(jrot,treat_vibration,task,fileh) - else - call restore_rot_kinetic_matrix_elements(jrot,treat_vibration,task,iunit) - endif + call restore_rot_kinetic_matrix_elements(jrot,treat_vibration,task) ! if (allocated(gmat)) deallocate(gmat) call ArrayStop('gmat-fields') @@ -1906,19 +1836,11 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! endif ! - if (trim(job%kinetmat_format).eq.'MPIIO') then -#ifdef TROVE_USE_MPI_ - call MPI_File_close(fileh, ierr) -#endif - else - ! 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 + if (allocated(ioHandler)) deallocate(ioHandler) ! ! External field part ! + ! TODO fix MPI here if (FLextF_matelem) then ! if (job%verbose>=3) write(out,"(/' Transform extF to J0-representation...')") @@ -2154,11 +2076,7 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! else ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - call divided_slice_write_mpi(imu,'extF',job%j0extmat_suffix,Neigenroots,mat_s,mat_s_block_type) - else - if(mpi_rank.eq.0) call divided_slice_write(imu,'extF',job%j0extmat_suffix,Neigenroots,mat_s) - endif + call divided_slice_write(imu,'extF',job%j0extmat_suffix,Neigenroots,mat_s,desc_mat_s,mat_s_block_type) ! endif ! @@ -2250,7 +2168,7 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! contains ! - subroutine divided_slice_write(islice,name,suffix,N,field) + subroutine divided_slice_write(islice,name,suffix,N,field, field_desc, block_type) ! implicit none ! @@ -2258,88 +2176,48 @@ subroutine divided_slice_write(islice,name,suffix,N,field) character(len=*),intent(in) :: name,suffix integer(ik),intent(in) :: N real(rk),intent(in) :: field(N,N) + integer, intent(in) :: field_desc(9) + type(MPI_Datatype),intent(in) :: block_type character(len=4) :: jchar - integer(ik) :: chkptIO + class(ioHandlerBase), allocatable :: ioHandler character(len=cl) :: buf,filename,job_is ! write(job_is,"('single swap_matrix')") ! - call IOStart(trim(job_is),chkptIO) - ! write(jchar, '(i4)') islice ! filename = trim(suffix)//trim(adjustl(jchar))//'.chk' ! - open(chkptIO,form='unformatted',action='write',position='rewind',status='replace',file=filename) - ! - write(chkptIO) trim(name) +#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 + call ioHandler%write(trim(name)) ! - write(chkptIO) field + call ioHandler%write(field, field_desc, block_type) ! - write(chkptIO) trim(name) + call ioHandler%write(trim(name)) ! close(chkptIO) ! end subroutine divided_slice_write ! ! - subroutine divided_slice_write_mpi(islice,name,suffix,N,field,block_type) - ! - implicit none - ! - integer(ik),intent(in) :: islice - character(len=*),intent(in) :: name,suffix - integer(ik),intent(in) :: N - real(rk),dimension(:,:),intent(in) :: field - type(MPI_Datatype),intent(in) :: block_type - -#ifdef TROVE_USE_MPI_ - character(len=4) :: jchar - character(len=cl) :: filename - type(MPI_File) :: chkptMPIIO - integer(kind=MPI_OFFSET_KIND) :: offset - integer :: ierr - ! - write(job_is,"('single swap_matrix MPI')") - ! - ! - write(jchar, '(i4)') islice - ! - filename = trim(suffix)//trim(adjustl(jchar))//'.chk' - ! - offset = 0 - call MPI_File_open(mpi_comm_world, filename, mpi_mode_wronly+mpi_mode_create, mpi_info_null, chkptMPIIO, ierr) - call MPI_File_set_size(chkptMPIIO, offset, ierr) - ! - if(mpi_rank .eq. 0) call MPI_File_write(chkptMPIIO,name,len(trim(name)),mpi_character,mpi_status_ignore,ierr) - ! - !call MPI_File_get_position(chkptMPIIO, offset, ierr) - offset = int(len(trim(name)),MPI_OFFSET_KIND) - call MPI_File_set_view(chkptMPIIO, offset, mpi_byte, block_type, "native", MPI_INFO_NULL, ierr) - ! - call MPI_File_write_all(chkptMPIIO, field, size(field), mpi_double_precision, mpi_status_ignore, ierr) - ! - offset = offset + N*int(N,MPI_OFFSET_KIND)*mpi_real_size - call MPI_File_set_view(chkptMPIIO, offset, mpi_byte, mpi_byte, "native", MPI_INFO_NULL, ierr) - ! - if(mpi_rank .eq. 0) call MPI_File_write(chkptMPIIO,name,len(trim(name)),mpi_character,mpi_status_ignore,ierr) - ! - call MPI_File_close(chkptMPIIO, ierr) - ! -#endif - end subroutine divided_slice_write_mpi - ! - ! - subroutine divided_slice_read(islice,name,suffix,N,field,field_descr,block_type,ierror) + subroutine divided_slice_read(islice,name,suffix,N,field,field_desc,block_type,ierror) ! implicit none ! integer(ik),intent(in) :: islice character(len=*),intent(in) :: name,suffix integer(ik),intent(in) :: N - integer, intent(in) :: field_descr(9) - type(MPI_Datatype),intent(in) :: block_type real(rk),intent(out) :: field(N,N) + integer, intent(in) :: field_desc(9) + type(MPI_Datatype),intent(in) :: block_type integer(ik),intent(out) :: ierror character(len=4) :: jchar class(ioHandlerBase), allocatable :: ioHandler @@ -2351,8 +2229,6 @@ subroutine divided_slice_read(islice,name,suffix,N,field,field_descr,block_type, ! write(job_is,"('single swap_matrix')") ! - call IOStart(trim(job_is),chkptIO) - ! write(jchar, '(i4)') islice ! filename = trim(suffix)//trim(adjustl(jchar))//'.chk' @@ -2377,7 +2253,7 @@ subroutine divided_slice_read(islice,name,suffix,N,field,field_descr,block_type, stop 'divided_slice_read - in slice - header missing or wrong' end if ! - call ioHandler%read(field, field_descr, block_type) + call ioHandler%read(field, field_desc, block_type) ! call ioHandler%read(buf(1:ilen)) if ( trim(buf(1:ilen))/=trim(name) ) then @@ -2405,7 +2281,7 @@ subroutine divided_slice_read(islice,name,suffix,N,field,field_descr,block_type, end subroutine divided_slice_read ! ! - subroutine divided_slice_read_vibrot(islice,suffix,N,field) + subroutine divided_slice_read_vibrot(islice,suffix,N,field,field_desc,block_type) ! implicit none ! @@ -2413,6 +2289,8 @@ subroutine divided_slice_read_vibrot(islice,suffix,N,field) character(len=*),intent(in) :: suffix integer(ik),intent(in) :: N real(rk),intent(out) :: field(N,N) + integer, intent(in) :: field_desc(9) + type(MPI_Datatype),intent(in) :: block_type character(len=4) :: jchar integer(ik) :: chkptIO character(len=cl) :: buf,filename,job_is @@ -2452,7 +2330,7 @@ subroutine divided_slice_read_vibrot(islice,suffix,N,field) end subroutine divided_slice_read_vibrot ! ! - subroutine divided_slice_write_vibrot(islice,suffix,N,field) + subroutine divided_slice_write_vibrot(islice,suffix,N,field,field_desc,block_type) ! implicit none ! @@ -2460,6 +2338,8 @@ subroutine divided_slice_write_vibrot(islice,suffix,N,field) character(len=*),intent(in) :: suffix integer(ik),intent(in) :: N real(rk),intent(in) :: field(N,N) + integer, intent(in) :: field_desc(9) + type(MPI_Datatype),intent(in) :: block_type character(len=4) :: jchar integer(ik) :: chkptIO character(len=cl) :: buf,filename,job_is @@ -2504,40 +2384,48 @@ end subroutine TRconvert_matel_j0_eigen ! Here we restore the vibrational (J=0) matrix elements of the rotational kinetic part G_rot and G_cor ! - subroutine restore_rot_kinetic_matrix_elements(jrot,treat_vibration,kinetic_part,chkptIO) - ! - implicit none - ! - integer(ik),intent(in) :: jrot - logical,intent(in) :: treat_vibration - character(len=3),intent(in) :: kinetic_part - integer(ik),intent(inout) :: chkptIO - ! - integer(ik) :: iclasses,alloc,ilevel,ib,max_deg_size,nclasses,islice - character(len=cl) :: job_is - character(len=18) :: buf18 - integer(ik) :: ncontr_t,rootsize - integer(ik),allocatable :: imat_t(:,:) - real(rk),allocatable :: mat_t(:) - ! - nclasses = bset_contr(1)%nclasses - ! - select case (kinetic_part) - ! - case('rot','top') + subroutine restore_rot_kinetic_matrix_elements(jrot,treat_vibration,kinetic_part) + ! + implicit none + ! + integer(ik),intent(in) :: jrot + logical,intent(in) :: treat_vibration + character(len=3),intent(in) :: kinetic_part + class(ioHandlerBase), allocatable :: ioHandler + type(ErrorType) :: err + ! + integer(ik) :: iclasses,alloc,ilevel,ib,max_deg_size,nclasses,islice + character(len=cl) :: job_is + character(len=18) :: buf18 + integer(ik) :: ncontr_t,rootsize + integer(ik),allocatable :: imat_t(:,:) + real(rk),allocatable :: mat_t(:) + ! + nclasses = bset_contr(1)%nclasses + ! + select case (kinetic_part) + ! + case('rot','top') ! job_is ='Vib. matrix elements of the rot. kinetic' - call IOStart(trim(job_is),chkptIO) ! - open(chkptIO,form='unformatted',action='read',position='rewind',status='old',file=job%kinetmat_file) +#ifdef TROVE_USE_MPI_ + allocate(ioHandler, & + source=ioHandlerMPI(job%kinetmat_file, err, action='read', & + position='rewind', status='old', form='unformatted')) +#else + allocate(ioHandler, & + source=ioHandlerFTN(job%kinetmat_file, err, action='read', & + position='rewind', status='old', form='unformatted')) +#endif ! - read(chkptIO) buf18 + call ioHandler%read(buf18) if (buf18/='Start Kinetic part') then write (out,"(' Vib. kinetic checkpoint file ',a,' has bogus header: ',a)") job%kinetmat_file,buf18 stop 'PTcontracted_matelem_class - bogus file format' end if ! - read(chkptIO) ncontr_t + call ioHandler%read(ncontr_t) ! if (bset_contr(1)%Maxcontracts/=ncontr_t) then write (out,"(' Vib. kinetic checkpoint file ',a)") job%kinetmat_file @@ -2554,13 +2442,13 @@ subroutine restore_rot_kinetic_matrix_elements(jrot,treat_vibration,kinetic_part allocate (imat_t(0:nclasses,ncontr_t),stat=alloc) call ArrayStart('contractive_space',alloc,size(imat_t),kind(imat_t)) ! - read(chkptIO) 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 'restore_rot_kinetic_matrix_elements - in file - icontr_cnu missing' end if ! - read(chkptIO) imat_t(0:nclasses,1:ncontr_t) + call ioHandler%read(imat_t(0:nclasses,1:ncontr_t)) ! if (job%vib_rot_contr) then ! @@ -2570,13 +2458,13 @@ subroutine restore_rot_kinetic_matrix_elements(jrot,treat_vibration,kinetic_part ! endif ! - read(chkptIO) 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 'restore_rot_kinetic_matrix_elements - in file - icontr_ideg missing' end if ! - read(chkptIO) imat_t(0:nclasses,1:ncontr_t) + call ioHandler%read(imat_t(0:nclasses,1:ncontr_t)) ! deallocate(imat_t) ! @@ -2586,7 +2474,7 @@ subroutine restore_rot_kinetic_matrix_elements(jrot,treat_vibration,kinetic_part ! if (trim(kinetic_part)=='rot') then ! - read(chkptIO) buf18(1:4) + call ioHandler%read(buf18(1:4)) if (buf18(1:4)/='g_ro') then write (out,"(' Vib. kinetic checkpoint file ',a,': g_rot is missing ',a)") trim(job%kinetmat_file),buf18(1:5) ! @@ -2600,13 +2488,6 @@ subroutine restore_rot_kinetic_matrix_elements(jrot,treat_vibration,kinetic_part endif ! if (job%vib_rot_contr) then - ! - !inquire(iolength=rec_len) f_t - !rec_len = rec_len*ncontr*PT%max_deg_size - !! - !do islice = 1,9+3*PT%Nmodes - ! call divided_slice_open_vib_rot(islice,rec_len,job%matelem_suffix) - !enddo ! call find_groundstate_icontr(bset_contr(1)%nclasses) ! @@ -2614,7 +2495,7 @@ subroutine restore_rot_kinetic_matrix_elements(jrot,treat_vibration,kinetic_part ! case('cor') ! - read(chkptIO) buf18(1:5) + call ioHandler%read(buf18(1:5)) if (buf18(1:5)/='g_cor') then write (out,"(' Vib. kinetic checkpoint file ',a,': g_cor is missing ',a)") job%kinetmat_file,buf18(1:5) stop 'restore_rot_kinetic_matrix_elements_posix - in file - g_cor missing' @@ -2630,13 +2511,13 @@ subroutine restore_rot_kinetic_matrix_elements(jrot,treat_vibration,kinetic_part ! endif ! - read(chkptIO) buf18(1:4) + call ioHandler%read(buf18(1:4)) if (buf18(1:4)/='hvib'.and.buf18(1:3)/='End'.and.buf18(1:4)/='vib-') then write (out,"(' Vib. kinetic checkpoint file ',a,': hvib, vib-rot, End is missing ',a)") job%kinetmat_file,buf18(1:4) stop 'restore_rot_kinetic_matrix_elements - in file - hvib or End missing' end if ! - close(chkptIO,status='keep') + deallocate (ioHandler) ! end select ! @@ -2750,252 +2631,6 @@ end subroutine find_groundstate_icontr end subroutine restore_rot_kinetic_matrix_elements ! ! - ! [MPIIO] Here we restore the vibrational (J=0) matrix elements of the rotational kinetic part G_rot and G_cor - ! - subroutine restore_rot_kinetic_matrix_elements_mpi(jrot,treat_vibration,kinetic_part,fileh) - use mpi_aux - ! - implicit none - ! - integer(ik),intent(in) :: jrot - logical,intent(in) :: treat_vibration - character(len=3),intent(in) :: kinetic_part - type(MPI_File),intent(in) :: fileh -#ifdef TROVE_USE_MPI_ - ! - integer(ik) :: iclasses,alloc,ilevel,ib,max_deg_size,nclasses,islice - character(len=cl) :: job_is - character(len=18) :: buf18 - integer(ik) :: ncontr_t,rootsize - integer(ik),allocatable :: imat_t(:,:) - real(rk),allocatable :: mat_t(:) - integer :: ierr - ! - nclasses = bset_contr(1)%nclasses - ! - select case (kinetic_part) - ! - case('rot','top') - ! - job_is ='Vib. matrix elements of the rot. kinetic [mpi]' - ! - call MPI_File_read_all(fileh, buf18, 7, mpi_character, mpi_status_ignore, ierr) - if (buf18(1:7)/='[MPIIO]') then - write (out,"(' Vib. kinetic checkpoint file ',a,' is not an MPIIO file: ',a)") job%kinetmat_file,buf18 - stop 'restore_rot_kinetic_matrix_elements_mpi - Not an MPIIO file' - end if - ! - call MPI_File_read_all(fileh, buf18, 18, mpi_character, mpi_status_ignore, ierr) - if (buf18/='Start Kinetic part') then - write (out,"(' Vib. kinetic checkpoint file ',a,' has bogus header: ',a)") job%kinetmat_file,buf18 - stop 'restore_rot_kinetic_matrix_elements_mpi - bogus file format' - end if - ! - call MPI_File_read_all(fileh, ncontr_t, 1, mpi_integer, mpi_status_ignore, ierr) - ! - if (bset_contr(1)%Maxcontracts/=ncontr_t) then - write (out,"(' Vib. kinetic checkpoint file ',a)") job%kinetmat_file - write (out,"(' Actual and stored basis sizes at J=0 do not agree ',2i0)") bset_contr(1)%Maxcontracts,ncontr_t - stop 'restore_rot_kinetic_matrix_elements_mpi - in file - illegal nroots ' - end if - ! - rootsize = bset_contr(1)%Maxcontracts*(bset_contr(1)%Maxcontracts+1)/2 - ! - if (job%verbose>=6) write(out,"(/'Restore_rot_kin...: Number of elements: ',i8)") bset_contr(1)%Maxcontracts - ! - ! Read the indexes of the J=0 contracted basis set. - ! - allocate (imat_t(0:nclasses,ncontr_t),stat=alloc) - call ArrayStart('contractive_space',alloc,size(imat_t),kind(imat_t)) - ! - call MPI_File_read_all(fileh, buf18, 10, mpi_character, mpi_status_ignore, ierr) - 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 'restore_rot_kinetic_matrix_elements_mpi - in file - icontr_cnu missing' - end if - ! - call MPI_File_read_all(fileh, imat_t, (nclasses+1)*ncontr_t, mpi_integer, mpi_status_ignore, ierr) - ! - if (job%vib_rot_contr) then - ! - allocate (TRicontr_cnu(0:nclasses,ncontr_t),stat=alloc) - call ArrayStart('TRicontr_cnu',alloc,size(TRicontr_cnu),kind(TRicontr_cnu)) - TRicontr_cnu = imat_t - ! - endif - ! - call MPI_File_read_all(fileh, buf18, 11, mpi_character, mpi_status_ignore, ierr) - if (buf18(1:11)/='icontr_ideg') then - write (out,"(' Vib. kinetic checkpoint file ',a,': icontr_ideg is missing ',a)") trim(job%kinetmat_file),buf18(1:11) - stop 'restore_rot_kinetic_matrix_elements_mpi - in file - icontr_ideg missing' - end if - ! - call MPI_File_read_all(fileh, imat_t, (nclasses+1)*ncontr_t, mpi_integer, mpi_status_ignore, ierr) - ! - deallocate(imat_t) - ! - call arraystop('contractive_space') - ! - ! Read the rotational part only if its really needed. - ! - if (trim(kinetic_part)=='rot') then - ! - call MPI_File_read_all(fileh, buf18, 5, mpi_character, mpi_status_ignore, ierr) - if (buf18(1:5)/='g_rot') then - write (out,"(' Vib. kinetic checkpoint file ',a,': g_rot is missing ',a)") trim(job%kinetmat_file),buf18(1:5) - ! - if (buf18(1:4)=='hvib'.or.buf18(1:3)=='End') & - write (out,"(a,a)") & - ' Most likely the split chk-points are supposed to be used.',& - 'Re-do MATELEM SAVE or use SPLIT in MATELEM !' - stop 'restore_rot_kinetic_matrix_elements_mpi - in file - g_rot missing' - end if - ! - endif - ! - if (job%vib_rot_contr) then - ! - call find_groundstate_icontr(bset_contr(1)%nclasses) - ! - endif - ! - case('cor') - ! - call MPI_File_read_all(fileh, buf18, 5, mpi_character, mpi_status_ignore, ierr) - if (buf18(1:5)/='g_cor') then - write (out,"(' Vib. kinetic checkpoint file ',a,': g_cor is missing ',a)") job%kinetmat_file,buf18(1:5) - stop 'restore_rot_kinetic_matrix_elements_mpi - in file - g_cor missing' - end if - ! - case('end') - ! - if (job%vib_rot_contr) then - ! - do islice = 1,9+3*FLNmodes - call divided_slice_close_vib_rot(islice) - enddo - ! - endif - ! - call MPI_File_read_all(fileh, buf18, 4, mpi_character, mpi_status_ignore, ierr) - if (buf18(1:4)/='hvib'.and.buf18(1:3)/='End'.and.buf18(1:4)/='vib-') then - write (out,"(' Vib. kinetic checkpoint file ',a,': hvib, vib-rot, End is missing ',a)") job%kinetmat_file,buf18(1:4) - stop 'restore_rot_kinetic_matrix_elements_mpi - in file - hvib or End missing' - end if - ! - end select - ! - contains - ! - subroutine divided_slice_open_vib_rot(islice,rec_len,suffix) - ! - implicit none - integer(ik),intent(in) :: islice,rec_len - character(len=*),intent(in) :: suffix - integer(ik) :: chkptIO - character(len=4) :: jchar - character(len=cl) :: buf,filename,job_is - integer(ik) :: ilen - logical :: ifopened - ! - if (.not.job%IOmatelem_split) return - ! - write(jchar, '(i4)') islice - ! - filename = trim(suffix)//trim(adjustl(jchar))//'.chk' - ! - write(job_is,"('single swap_matrix #',i8)") islice - ! - call IOStart(trim(job_is),chkptIO) - ! - ! use direct access format for vib-rot - ! - open(chkptIO,access='direct',action='read',status='old',recl=rec_len,file=filename) - ! - end subroutine divided_slice_open_vib_rot - ! - subroutine divided_slice_close_vib_rot(islice) - ! - implicit none - integer(ik),intent(in) :: islice - integer(ik) :: chkptIO - character(len=4) :: jchar - character(len=cl) :: filename,job_is - integer(ik) :: ilen - ! - if (.not.job%IOmatelem_split) return - ! - write(jchar, '(i4)') islice - ! - write(job_is,"('single swap_matrix #',i8)") islice - ! - call IOStart(trim(job_is),chkptIO) - ! - ! use direct access format for vib-rot - ! - close(chkptIO,status='keep') - ! - end subroutine divided_slice_close_vib_rot - ! - ! find correspondence between contracted quantum numbers: current and for J=0 - ! - subroutine find_groundstate_icontr(Nclasses) - ! - integer(ik), intent(in) :: Nclasses - integer(ik) :: maxcontr - ! - integer(ik) :: icontr,iterm,cnu_(1:bset_contr(1)%nclasses),icontr0,alloc,maxcontr0 - ! - if (job%verbose>=4) write(out,"(' Find correlation between J=0 and J/=0 contr. basis functions...')") - ! - maxcontr = size(TRicontr_cnu,dim=2) - ! - ! count icontr0-s - icontr0 = 0 - cnu_ = 0 - ! - do icontr = 1,maxcontr - ! - if (any(TRicontr_cnu(1:Nclasses,icontr)/=cnu_(1:Nclasses))) then - ! - icontr0 = icontr0 + 1 - cnu_ = TRicontr_cnu(1:Nclasses,icontr) - ! - endif - ! - enddo - ! - maxcontr0 = icontr0 - ! - allocate(Ncontr02icase0(maxcontr0,2),stat=alloc) - call ArrayStart('Ncontr02icase0',alloc,size(Ncontr02icase0),kind(Ncontr02icase0)) - ! - ! count ideg0 - icontr0 = 0 - cnu_ = 0 - ! - Ncontr02icase0(1,1) = 1 - Ncontr02icase0(maxcontr0,2) = maxcontr - ! - do icontr = 1,maxcontr - ! - if (any(TRicontr_cnu(1:Nclasses,icontr)/=cnu_(1:Nclasses))) then - ! - icontr0 = icontr0 + 1 - cnu_ = TRicontr_cnu(1:Nclasses,icontr) - Ncontr02icase0(icontr0,1) = icontr - if (icontr0>1) Ncontr02icase0(icontr0-1,2) = icontr-1 - ! - endif - ! - enddo - ! - end subroutine find_groundstate_icontr - ! -#endif - end subroutine restore_rot_kinetic_matrix_elements_mpi - ! - ! subroutine eigen_vib_matelem_vector(iparity,ilevelI,irootI,nlevels,nroots,cdimenmax,icoeff,fcoeff,cdimen,field,mat) ! implicit none From 9b702bb6faabb89de539e2d50ddfb086fc460fc5 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 21 Oct 2021 16:47:05 +0100 Subject: [PATCH 13/66] Implement iohandlers in matelem reading --- io_handler_ftn.f90 | 84 ++++++++++++++++++++++------------ perturbation.f90 | 4 +- tran.f90 | 111 ++++++++++++++++++++------------------------- 3 files changed, 108 insertions(+), 91 deletions(-) diff --git a/io_handler_ftn.f90 b/io_handler_ftn.f90 index c210f82..a46a03c 100644 --- a/io_handler_ftn.f90 +++ b/io_handler_ftn.f90 @@ -93,12 +93,16 @@ subroutine open(this, fname, err, action, position, status, form, access) accessVal = 'sequential' end if - print *, "FTN: Opening ", trim(fname), " with ", \ - trim(positionVal), " ", trim(statusVal), " ", trim(formVal), " ", trim(accessVal) + print *, "FTN: Opening ", trim(fname), " with ", & + trim(action), " ", & + trim(positionVal), " ", & + trim(statusVal), " ", & + trim(formVal), " ", & + trim(accessVal) - open(newunit=this%iounit, action=action,\ - form=formVal, position=positionVal, status=statusVal, file=fname,\ - iostat=this%stat) + open(newunit=this%iounit, action=action, & + form=formVal, position=positionVal, status=statusVal, & + access=accessVal, file=fname, iostat=this%stat) if (this%stat == 0) then this%isOpen = .true. @@ -118,7 +122,7 @@ subroutine close(this) subroutine writeScalarFTN(this, object) class(ioHandlerFTN) :: this class(*), intent(in) :: object - print *, "writing scalar object with FTN IO" + select type(object) type is (integer) write(this%iounit) object @@ -127,16 +131,16 @@ subroutine writeScalarFTN(this, object) type is (complex) write(this%iounit) object type is (character(len=*)) - write(this%iounit) object + write(this%iounit) trim(object) class default - print *, "ERROR: Tried to write unsupported type" + stop "ioHandlerFTN%writeScalarFTN: Tried to write unsupported type" end select end subroutine subroutine write1DArrayFTN(this, object) class(ioHandlerFTN) :: this class(*), dimension(:), intent(in) :: object - print *, "writing 1D array with FTN IO" + select type(object) type is (integer) write(this%iounit) object @@ -145,14 +149,14 @@ subroutine write1DArrayFTN(this, object) type is (complex) write(this%iounit) object class default - print *, "ERROR: Tried to write unsupported type" + stop "ioHandlerFTN%write1DArrayFTN: Tried to write unsupported type" end select end subroutine subroutine write2DArrayFTN(this, object) class(ioHandlerFTN) :: this class(*), dimension(:,:), intent(in) :: object - print *, "writing 2D array with FTN IO" + select type(object) type is (integer(int32)) write(this%iounit) object @@ -167,7 +171,7 @@ subroutine write2DArrayFTN(this, object) type is (complex(kind=8)) write(this%iounit) object class default - print *, "ERROR: Tried to write unsupported type" + stop "ioHandlerFTN%write2DArrayFTN: Tried to write unsupported type" end select end subroutine @@ -197,60 +201,82 @@ subroutine write2DArrayDistColumnFTN(this, object, mdimen) subroutine readScalarFTN(this, object) class(ioHandlerFTN) :: this class(*), intent(out) :: object - print *, "reading object with FTN IO" + select type(object) - type is (integer) + type is (integer(int32)) read(this%iounit) object - type is (real) + type is (integer(int64)) read(this%iounit) object - type is (complex) + type is (real(real32)) + read(this%iounit) object + type is (real(real64)) + read(this%iounit) object + type is (complex(kind=4)) + read(this%iounit) object + type is (complex(kind=8)) + read(this%iounit) object + type is (character(len=*)) + !print *, object + !stop "DEBUG readScalarFTN" read(this%iounit) object class default - print *, "Unsupported type!" + stop "ioHandlerFTN%readScalarFTN: Tried to read 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) + type is (integer(int32)) read(this%iounit) object - type is (real) + type is (integer(int64)) read(this%iounit) object - type is (complex) + type is (real(real32)) + read(this%iounit) object + type is (real(real64)) + read(this%iounit) object + type is (complex(kind=4)) + read(this%iounit) object + type is (complex(kind=8)) read(this%iounit) object class default - print *, "Unsupported type!" + stop "ioHandlerFTN%read1DArrayFTN: Tried to read 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) + type is (integer(int32)) read(this%iounit) object - type is (real) + type is (integer(int64)) read(this%iounit) object - type is (complex) + type is (real(real32)) + read(this%iounit) object + type is (real(real64)) + read(this%iounit) object + type is (complex(kind=4)) + read(this%iounit) object + type is (complex(kind=8)) read(this%iounit) object class default - print *, "Unsupported type!" + stop "ioHandlerFTN%read2DArrayFTN: Tried to read unsupported type" end select end subroutine subroutine read2DArrayDistBlacsFTN(this, object, descr, block_type) - ! Write arrays distributed as columns using co_distr_data + ! read arrays distributed as columns using co_distr_data class(ioHandlerFTN) :: this class(*), dimension(:,:), intent(out) :: object integer, intent(in) :: descr(9) ! Description array outputted from co_block_type_init type(MPI_Datatype), intent(in) :: block_type - ! Using the fortran io_handler means array isn't distributed, just write normally + ! Using the fortran io_handler means array isn't distributed, just read normally call this%read2DArray(object) end subroutine end module diff --git a/perturbation.f90 b/perturbation.f90 index 49921a1..388ecdb 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -9890,7 +9890,9 @@ recursive subroutine symm_mat_element_vector_k(jrot,irow,ijterm,func,mat_t,no_di ! do jrow = 1,irow ! - if ( present(no_diagonalization).and.no_diagonalization.and.jrow/=irow ) cycle + if (present(no_diagonalization)) then + if (no_diagonalization.and.jrow/=irow ) cycle + endif ! cnu_j(:) = PT%contractive_space(:,jrow) ! diff --git a/tran.f90 b/tran.f90 index 6b28dc1..3aaaf69 100644 --- a/tran.f90 +++ b/tran.f90 @@ -1326,7 +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 + class(ioHandlerBase), allocatable :: kineteigenHandler + class(ioHandlerBase), allocatable :: kinetmatHandler type(ErrorType) :: err type(MPI_Datatype) :: gmat_block_type, psi_block_type, mat_t_block_type, mat_s_block_type, extF_block_type @@ -1614,21 +1615,21 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! call IOStart(trim(job_is),chkptIO) #ifdef TROVE_USE_MPI_ - allocate(ioHandler, & + allocate(kineteigenHandler, & source=ioHandlerMPI(job%kineteigen_file, err, action='write', & position='rewind', status='replace', form='unformatted')) #else - allocate(ioHandler, & + allocate(kineteigenHandler, & source=ioHandlerFTN(job%kineteigen_file, err, action='write', & position='rewind', status='replace', form='unformatted')) #endif HANDLE_ERROR(err) - call ioHandler%write('Start Kinetic part') + call kineteigenHandler%write('Start Kinetic part') treat_vibration = .false. - call PTstore_icontr_cnu(Neigenroots,ioHandler,job%IOj0matel_action) + call PTstore_icontr_cnu(Neigenroots,kineteigenHandler,job%IOj0matel_action) if (job%vib_rot_contr) then - call ioHandler%write('vib-rot') + call kineteigenHandler%write('vib-rot') endif ! endif @@ -1671,10 +1672,20 @@ subroutine TRconvert_matel_j0_eigen(jrot) task = 'top' else task = 'rot' - call ioHandler%write('g_rot') + call kineteigenHandler%write('g_rot') endif - call restore_rot_kinetic_matrix_elements(jrot,treat_vibration,task) +#ifdef TROVE_USE_MPI_ + allocate(kinetmatHandler, & + source=ioHandlerMPI(job%kinetmat_file, err, action='read', & + position='rewind', status='old', form='unformatted')) +#else + allocate(kinetmatHandler, & + source=ioHandlerFTN(job%kinetmat_file, err, action='read', & + position='rewind', status='old', form='unformatted')) +#endif + + call restore_rot_kinetic_matrix_elements(jrot,treat_vibration,task,kinetmatHandler) ! if (job%verbose>=5) call TimerStart('J0-convertion for g_rot') ! @@ -1700,7 +1711,7 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! else ! - call ioHandler%read(gmat, desc_gmat, gmat_block_type) + call kineteigenHandler%read(gmat, desc_gmat, gmat_block_type) ! endif ! @@ -1729,23 +1740,13 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! else ! - call ioHandler%write(mat_s, desc_mat_s, mat_s_block_type) + call kineteigenHandler%write(mat_s, desc_mat_s, mat_s_block_type) ! endif ! enddo ! enddo - ! - ! Reset view to flat file - if ((.not.job%IOmatelem_split) .and. blacs_size.gt.1) then -#ifdef TROVE_USE_MPI_ - 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) -#endif - endif - ! if (job%verbose>=5) call TimerStop('J0-convertion for g_rot') ! @@ -1755,8 +1756,8 @@ subroutine TRconvert_matel_j0_eigen(jrot) if (.not.job%IOmatelem_split) then ! task = 'cor' - call restore_rot_kinetic_matrix_elements(jrot,treat_vibration,task) - call ioHandler%write('g_cor') + call restore_rot_kinetic_matrix_elements(jrot,treat_vibration,task,kinetmatHandler) + call kineteigenHandler%write('g_cor') ! endif ! @@ -1786,7 +1787,7 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! else ! - call ioHandler%read(gmat,desc_gmat,gmat_block_type) + call kineteigenHandler%read(gmat,desc_gmat,gmat_block_type) ! endif ! @@ -1812,7 +1813,7 @@ subroutine TRconvert_matel_j0_eigen(jrot) call divided_slice_write(islice,'g_cor',job%j0matelem_suffix,Neigenroots,mat_s,desc_mat_s,mat_s_block_type) endif else - call ioHandler%write(mat_s, desc_mat_s, mat_s_block_type) + call kineteigenHandler%write(mat_s, desc_mat_s, mat_s_block_type) endif ! enddo @@ -1821,22 +1822,23 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! 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 - call ioHandler%write('End Kinetic part') + if ((.not.job%IOmatelem_split.or.job%iswap(1)==1)) then + call kineteigenHandler%write('End Kinetic part') endif ! task = 'end' ! - call restore_rot_kinetic_matrix_elements(jrot,treat_vibration,task) + call restore_rot_kinetic_matrix_elements(jrot,treat_vibration,task,kinetmatHandler) ! if (allocated(gmat)) deallocate(gmat) + if (allocated(kinetmatHandler)) deallocate(kinetmatHandler) call ArrayStop('gmat-fields') ! if (job%verbose>=3) write(out,"(' ...done!')") ! endif ! - if (allocated(ioHandler)) deallocate(ioHandler) + if (allocated(kineteigenHandler)) deallocate(kineteigenHandler) ! ! External field part ! @@ -2190,18 +2192,18 @@ subroutine divided_slice_write(islice,name,suffix,N,field, field_desc, block_typ ! #ifdef TROVE_USE_MPI_ allocate(ioHandler, & - source=ioHandlerMPI(job%kinetmat_file, err, action='write', & + source=ioHandlerMPI(filename, err, action='write', & position='rewind', status='replace', form='unformatted')) #else allocate(ioHandler, & - source=ioHandlerFTN(job%kinetmat_file, err, action='write', & + source=ioHandlerFTN(filename, err, action='write', & position='rewind', status='replace', form='unformatted')) #endif - call ioHandler%write(trim(name)) + call ioHandler%write(name) ! call ioHandler%write(field, field_desc, block_type) ! - call ioHandler%write(trim(name)) + call ioHandler%write(name) ! close(chkptIO) ! @@ -2235,14 +2237,12 @@ subroutine divided_slice_read(islice,name,suffix,N,field,field_desc,block_type,i ! #ifdef TROVE_USE_MPI_ allocate(ioHandler, & - source=ioHandlerMPI(& - job%kineteigen_file, err, & - action='read', position='rewind', status='old', form='unformatted')) + source=ioHandlerMPI(filename, err, action='read', & + position='rewind', status='old', form='unformatted')) #else allocate(ioHandler, & - source=ioHandlerFTN(& - job%kineteigen_file, err, & - action='read', position='rewind', status='old', form='unformatted')) + source=ioHandlerFTN(filename, err, action='read', & + position='rewind', status='old', form='unformatted')) #endif ! ilen = LEN_TRIM(name) @@ -2384,14 +2384,14 @@ end subroutine TRconvert_matel_j0_eigen ! Here we restore the vibrational (J=0) matrix elements of the rotational kinetic part G_rot and G_cor ! - subroutine restore_rot_kinetic_matrix_elements(jrot,treat_vibration,kinetic_part) + subroutine restore_rot_kinetic_matrix_elements(jrot,treat_vibration,kinetic_part,fileHandler) ! implicit none ! integer(ik),intent(in) :: jrot logical,intent(in) :: treat_vibration character(len=3),intent(in) :: kinetic_part - class(ioHandlerBase), allocatable :: ioHandler + class(ioHandlerBase), intent(in) :: fileHandler type(ErrorType) :: err ! integer(ik) :: iclasses,alloc,ilevel,ib,max_deg_size,nclasses,islice @@ -2402,6 +2402,7 @@ subroutine restore_rot_kinetic_matrix_elements(jrot,treat_vibration,kinetic_part real(rk),allocatable :: mat_t(:) ! nclasses = bset_contr(1)%nclasses + ! select case (kinetic_part) ! @@ -2409,23 +2410,13 @@ subroutine restore_rot_kinetic_matrix_elements(jrot,treat_vibration,kinetic_part ! job_is ='Vib. matrix elements of the rot. kinetic' ! -#ifdef TROVE_USE_MPI_ - allocate(ioHandler, & - source=ioHandlerMPI(job%kinetmat_file, err, action='read', & - position='rewind', status='old', form='unformatted')) -#else - allocate(ioHandler, & - source=ioHandlerFTN(job%kinetmat_file, err, action='read', & - position='rewind', status='old', form='unformatted')) -#endif - ! - call ioHandler%read(buf18) + call fileHandler%read(buf18) if (buf18/='Start Kinetic part') then write (out,"(' Vib. kinetic checkpoint file ',a,' has bogus header: ',a)") job%kinetmat_file,buf18 stop 'PTcontracted_matelem_class - bogus file format' end if ! - call ioHandler%read(ncontr_t) + call fileHandler%read(ncontr_t) ! if (bset_contr(1)%Maxcontracts/=ncontr_t) then write (out,"(' Vib. kinetic checkpoint file ',a)") job%kinetmat_file @@ -2442,13 +2433,13 @@ subroutine restore_rot_kinetic_matrix_elements(jrot,treat_vibration,kinetic_part allocate (imat_t(0:nclasses,ncontr_t),stat=alloc) call ArrayStart('contractive_space',alloc,size(imat_t),kind(imat_t)) ! - call ioHandler%read(buf18(1:10)) + call fileHandler%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 'restore_rot_kinetic_matrix_elements - in file - icontr_cnu missing' end if ! - call ioHandler%read(imat_t(0:nclasses,1:ncontr_t)) + call fileHandler%read(imat_t(0:nclasses,1:ncontr_t)) ! if (job%vib_rot_contr) then ! @@ -2458,13 +2449,13 @@ subroutine restore_rot_kinetic_matrix_elements(jrot,treat_vibration,kinetic_part ! endif ! - call ioHandler%read(buf18(1:11)) + call fileHandler%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 'restore_rot_kinetic_matrix_elements - in file - icontr_ideg missing' end if ! - call ioHandler%read(imat_t(0:nclasses,1:ncontr_t)) + call fileHandler%read(imat_t(0:nclasses,1:ncontr_t)) ! deallocate(imat_t) ! @@ -2474,7 +2465,7 @@ subroutine restore_rot_kinetic_matrix_elements(jrot,treat_vibration,kinetic_part ! if (trim(kinetic_part)=='rot') then ! - call ioHandler%read(buf18(1:4)) + call fileHandler%read(buf18(1:4)) if (buf18(1:4)/='g_ro') then write (out,"(' Vib. kinetic checkpoint file ',a,': g_rot is missing ',a)") trim(job%kinetmat_file),buf18(1:5) ! @@ -2495,7 +2486,7 @@ subroutine restore_rot_kinetic_matrix_elements(jrot,treat_vibration,kinetic_part ! case('cor') ! - call ioHandler%read(buf18(1:5)) + call fileHandler%read(buf18(1:5)) if (buf18(1:5)/='g_cor') then write (out,"(' Vib. kinetic checkpoint file ',a,': g_cor is missing ',a)") job%kinetmat_file,buf18(1:5) stop 'restore_rot_kinetic_matrix_elements_posix - in file - g_cor missing' @@ -2511,14 +2502,12 @@ subroutine restore_rot_kinetic_matrix_elements(jrot,treat_vibration,kinetic_part ! endif ! - call ioHandler%read(buf18(1:4)) + call fileHandler%read(buf18(1:4)) if (buf18(1:4)/='hvib'.and.buf18(1:3)/='End'.and.buf18(1:4)/='vib-') then write (out,"(' Vib. kinetic checkpoint file ',a,': hvib, vib-rot, End is missing ',a)") job%kinetmat_file,buf18(1:4) stop 'restore_rot_kinetic_matrix_elements - in file - hvib or End missing' end if ! - deallocate (ioHandler) - ! end select ! contains From ccaf0c3bfc64960674fc9a352134bbd9f569e6e6 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Fri, 22 Oct 2021 16:21:09 +0100 Subject: [PATCH 14/66] Switch to calling openFile function to allocate the correct ioHandler and open a file using it --- io_factory.f90 | 37 ++++++++++++++++++++++++++++++++ io_handler_base.f90 | 11 ++++++++++ io_handler_ftn.f90 | 19 ----------------- io_handler_mpi.f90 | 35 +++++++++++++++--------------- makefile | 7 +++--- perturbation.f90 | 24 +++++++-------------- tran.f90 | 52 +++++++++++++-------------------------------- 7 files changed, 92 insertions(+), 93 deletions(-) create mode 100644 io_factory.f90 diff --git a/io_factory.f90 b/io_factory.f90 new file mode 100644 index 0000000..36b37bc --- /dev/null +++ b/io_factory.f90 @@ -0,0 +1,37 @@ +module io_factory + use mpi_aux + use io_handler_base + use io_handler_ftn +#ifdef TROVE_USE_MPI_ + use io_handler_mpi +#endif + use errors + implicit none + + contains + subroutine allocateHandler(ioHandler) + class(ioHandlerBase), allocatable, intent(out) :: ioHandler +#ifdef TROVE_USE_MPI_ + if (blacs_size > 1) then + ! Only allocate MPI IO when compiled with MPI *and* + ! running with more than one MPI process + allocate(ioHandlerMPI::ioHandler) + else + allocate(ioHandlerFTN::ioHandler) + endif +#else + allocate(ioHandlerFTN::ioHandler) +#endif + end subroutine + + subroutine openFile(ioHandler, filename, err, action, position, status, form, access) + class(ioHandlerBase), allocatable, intent(out) :: ioHandler + character (len = *), intent(in) :: filename + type(ErrorType), intent(inout) :: err + character (len = *), intent(in) :: action + character (len = *), intent(in), optional :: position, status, form, access + + call allocateHandler(ioHandler) + call ioHandler%open(filename, err, action, position, status, form, access) + end subroutine +end module diff --git a/io_handler_base.f90 b/io_handler_base.f90 index 1b83a14..4b9db18 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 @@ -19,6 +21,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 a46a03c..5f36e84 100644 --- a/io_handler_ftn.f90 +++ b/io_handler_ftn.f90 @@ -27,31 +27,12 @@ module io_handler_ftn final :: destroyIoHandlerFTN end type ioHandlerFTN - ! Constructor - interface ioHandlerFTN - procedure :: newIoHandlerFTN - end interface ioHandlerFTN - private public :: ioHandlerFTN contains - 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, action, position, status, form, access) - end function - subroutine destroyIoHandlerFTN(this) type(ioHandlerFTN) :: this call this%close() diff --git a/io_handler_mpi.f90 b/io_handler_mpi.f90 index 6ece336..d0735c3 100644 --- a/io_handler_mpi.f90 +++ b/io_handler_mpi.f90 @@ -17,7 +17,7 @@ type is (character(len=*)); \ call function(handle, obj, size, mytype, status, err); \ class default; \ - write(*,*) 'Not covered'; \ + stop 'MPI: tried to handle unsupported type'; \ end select @@ -31,7 +31,7 @@ module io_handler_mpi implicit none type, extends(ioHandlerBase) :: ioHandlerMPI - integer (kind=MPI_Offset_kind) :: bookendBytes + integer (kind=MPI_Offset_kind) :: bookendBytes = 0 integer :: rank = -1 type(MPI_File) :: fileh logical :: isOpen = .false. @@ -52,26 +52,12 @@ module io_handler_mpi final :: destroyIoHandlerMPI end type ioHandlerMPI - interface ioHandlerMPI - procedure :: newIoHandlerMPI - end interface ioHandlerMPI - private public :: ioHandlerMPI contains - type(ioHandlerMPI) function newIoHandlerMPI(fname, err, action, position, status, form, access) result(this) - ! writer MPI constructor - 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, action, position, status, form, access) - end function - subroutine destroyIoHandlerMPI(this) type(ioHandlerMPI) :: this call this%close() @@ -360,8 +346,21 @@ subroutine read1DArrayMPI(this, object) subroutine read2DArrayMPI(this, object) class(ioHandlerMPI) :: this - class(*), dimension(:,:), intent(out) :: object - stop "reading 2D array with MPI IO without specifying distribution not supported" + class(*), intent(out) :: object(:,:) + + type(MPI_Datatype) :: mpiType + integer :: byteSize, globalSize, ierr, length, arrSizeBytes + + integer(kind = MPI_OFFSET_KIND) :: offset + + globalSize = size(object) + + call getMPIVarInfo(object(1,1), byteSize, mpiType) + arrSizeBytes = globalSize*byteSize + + call MPI_File_seek(this%fileh, this%bookendBytes, MPI_SEEK_CUR, ierr) + MPI_WRAPPER(MPI_File_read_all, this%fileh, object, globalSize, mpiType, MPI_STATUS_IGNORE, ierr) + call MPI_File_seek(this%fileh, this%bookendBytes, MPI_SEEK_CUR, ierr) end subroutine subroutine read2DArrayDistBlacsMPI(this, object, descr, block_type) diff --git a/makefile b/makefile index f5fbf2f..3feb6cf 100644 --- a/makefile +++ b/makefile @@ -101,7 +101,7 @@ 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 \ - io_handler_base.f90 io_handler_ftn.f90 \ + io_handler_base.f90 io_handler_ftn.f90 io_factory.f90 \ refinement.f90 richmol_data.f90 rotme_cart_tens.f90 symmetry.f90 tran.f90 trove.f90 $(pot_user).f90 $(MPI_SRCS) OBJS := ${SRCS:.f90=.o} @@ -215,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 io_handler_base.o io_handler_ftn.o $(MPI_OBJS) +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_factory.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 @@ -236,8 +236,9 @@ 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 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 +tran.o: tran.f90 accuracy.o timer.o me_numer.o molecules.o fields.o moltype.o symmetry.o perturbation.o mpi_aux.o io_factory.o io_handler_base.o io_handler_ftn.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_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_factory.o: io_factory.f90 io_handler_base.o io_handler_ftn.o mpi_aux.o $(MPI_OBJS) diff --git a/perturbation.f90 b/perturbation.f90 index 388ecdb..b07ab35 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -15,6 +15,7 @@ module perturbation use symmetry , only : SymmetryInitialize,sym use me_numer use diag + use io_factory use io_handler_base use io_handler_ftn #ifdef TROVE_USE_MPI_ @@ -16286,15 +16287,8 @@ subroutine PTcontracted_matelem_class(jrot) job_is ='Vib. matrix elements of the rot. kinetic part' 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')) -#else - allocate(ioHandler, & - source=ioHandlerFTN(job%kinetmat_file, err, action='write', & - position='rewind', status='replace', form='unformatted')) -#endif + call openFile(ioHandler, job%kinetmat_file, err, action='write', & + position='rewind', status='replace', form='unformatted') HANDLE_ERROR(err) call ioHandler%write('Start Kinetic part') @@ -17936,11 +17930,10 @@ subroutine PTcontracted_matelem_class_fast_II(jrot) job_is ='Vib. matrix elements of the rot. kinetic part' call IOStart(trim(job_is),chkptIO) - ! TODO should this just be fortran writer? - allocate(ioHandler, & - source=ioHandlerFTN(job%kinetmat_file, err, action='write', & - position='rewind', status='replace', form='unformatted')) + call openFile(ioHandler, 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 @@ -38356,9 +38349,8 @@ 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(job%kinetmat_file, err, action='write',& - position='rewind', status='replace', form='unformatted')) + call openFile(ioHandler, job%kinetmat_file, err, 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 3aaaf69..1332a4d 100644 --- a/tran.f90 +++ b/tran.f90 @@ -22,6 +22,7 @@ module tran #ifdef TROVE_USE_MPI_ use io_handler_mpi #endif + use io_factory use errors private @@ -1614,16 +1615,11 @@ subroutine TRconvert_matel_j0_eigen(jrot) job_is ='Eigen-vib. matrix elements of the rot. kinetic part' ! call IOStart(trim(job_is),chkptIO) -#ifdef TROVE_USE_MPI_ - allocate(kineteigenHandler, & - source=ioHandlerMPI(job%kineteigen_file, err, action='write', & - position='rewind', status='replace', form='unformatted')) -#else - allocate(kineteigenHandler, & - source=ioHandlerFTN(job%kineteigen_file, err, action='write', & - position='rewind', status='replace', form='unformatted')) -#endif + + call openFile(kineteigenHandler, job%kineteigen_file, err, action='write', & + position='rewind', status='replace', form='unformatted') HANDLE_ERROR(err) + call kineteigenHandler%write('Start Kinetic part') treat_vibration = .false. @@ -1675,15 +1671,9 @@ subroutine TRconvert_matel_j0_eigen(jrot) call kineteigenHandler%write('g_rot') endif -#ifdef TROVE_USE_MPI_ - allocate(kinetmatHandler, & - source=ioHandlerMPI(job%kinetmat_file, err, action='read', & - position='rewind', status='old', form='unformatted')) -#else - allocate(kinetmatHandler, & - source=ioHandlerFTN(job%kinetmat_file, err, action='read', & - position='rewind', status='old', form='unformatted')) -#endif + call openFile(kinetmatHandler, job%kinetmat_file, err, action='read', & + position='rewind', status='old', form='unformatted') + HANDLE_ERROR(err) call restore_rot_kinetic_matrix_elements(jrot,treat_vibration,task,kinetmatHandler) ! @@ -2190,15 +2180,10 @@ subroutine divided_slice_write(islice,name,suffix,N,field, field_desc, block_typ ! filename = trim(suffix)//trim(adjustl(jchar))//'.chk' ! -#ifdef TROVE_USE_MPI_ - allocate(ioHandler, & - source=ioHandlerMPI(filename, err, action='write', & - position='rewind', status='replace', form='unformatted')) -#else - allocate(ioHandler, & - source=ioHandlerFTN(filename, err, action='write', & - position='rewind', status='replace', form='unformatted')) -#endif + call openFile(ioHandler, filename, err, action='write', & + position='rewind', status='replace', form='unformatted') + HANDLE_ERROR(err) + call ioHandler%write(name) ! call ioHandler%write(field, field_desc, block_type) @@ -2235,15 +2220,9 @@ subroutine divided_slice_read(islice,name,suffix,N,field,field_desc,block_type,i ! filename = trim(suffix)//trim(adjustl(jchar))//'.chk' ! -#ifdef TROVE_USE_MPI_ - allocate(ioHandler, & - source=ioHandlerMPI(filename, err, action='read', & - position='rewind', status='old', form='unformatted')) -#else - allocate(ioHandler, & - source=ioHandlerFTN(filename, err, action='read', & - position='rewind', status='old', form='unformatted')) -#endif + call openFile(ioHandler, filename, err, action='read', & + position='rewind', status='old', form='unformatted') + HANDLE_ERROR(err) ! ilen = LEN_TRIM(name) ! @@ -2402,7 +2381,6 @@ subroutine restore_rot_kinetic_matrix_elements(jrot,treat_vibration,kinetic_part real(rk),allocatable :: mat_t(:) ! nclasses = bset_contr(1)%nclasses - ! select case (kinetic_part) ! From eb36d059db2f96fe3f89756f3513fb7727c19f40 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Fri, 22 Oct 2021 17:38:40 +0100 Subject: [PATCH 15/66] Fix incorrect reader being used --- tran.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tran.f90 b/tran.f90 index 1332a4d..31dde78 100644 --- a/tran.f90 +++ b/tran.f90 @@ -1701,7 +1701,7 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! else ! - call kineteigenHandler%read(gmat, desc_gmat, gmat_block_type) + call kinetmatHandler%read(gmat, desc_gmat, gmat_block_type) ! endif ! @@ -1777,7 +1777,7 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! else ! - call kineteigenHandler%read(gmat,desc_gmat,gmat_block_type) + call kinetmatHandler%read(gmat,desc_gmat,gmat_block_type) ! endif ! From a0593f5b44e9fbc4ebfe56a352535ba9c838d6d6 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Fri, 22 Oct 2021 17:47:26 +0100 Subject: [PATCH 16/66] Run benchmark with MPI if makefile called with USE_MPI --- test/regression/scripts/H2CO/run_benchmark.sh | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/test/regression/scripts/H2CO/run_benchmark.sh b/test/regression/scripts/H2CO/run_benchmark.sh index 644e8a2..7a25c76 100755 --- a/test/regression/scripts/H2CO/run_benchmark.sh +++ b/test/regression/scripts/H2CO/run_benchmark.sh @@ -14,13 +14,19 @@ export OMP_NUM_THREADS=$nproc # Ensure stacksize unlimited (for fortran) ulimit -d unlimited -LAUNCH="time" +if [ -n "${USE_MPI}" ]; then + echo "MPI enabled" + LAUNCH="mpirun -np 4 --mca opal_warn_on_missing_libcuda 0" +else + echo "MPI disabled" + LAUNCH="time" +fi echo "Time: `date`" echo "Current directory: `pwd`" for name in file{1..12} file_intensity; do - $LAUNCH ./$exe < $name.inp > $name.out + $LAUNCH ./$exe $name.inp > $name.out done echo "DONE" From 0d7e987c27e7c58d107fbcdbed860a7f11a106fe Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Tue, 26 Oct 2021 12:52:05 +0100 Subject: [PATCH 17/66] Remove -ppn option from mpirun in regression benchmark; not portable --- test/regression/scripts/H2CO/run_benchmark.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/regression/scripts/H2CO/run_benchmark.sh b/test/regression/scripts/H2CO/run_benchmark.sh index a038a05..ba8db20 100755 --- a/test/regression/scripts/H2CO/run_benchmark.sh +++ b/test/regression/scripts/H2CO/run_benchmark.sh @@ -14,7 +14,7 @@ ulimit -d unlimited if [ -n "${USE_MPI}" ]; then echo "MPI enabled" - LAUNCH="time mpirun -ppn -np $nproc --mca opal_warn_on_missing_libcuda 0" + LAUNCH="time mpirun -np $nproc --mca opal_warn_on_missing_libcuda 0" ./set_io_format.sh enable export OMP_NUM_THREADS=1 else From 5be51d564a5eaaf2548462436900029f241ce6f8 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Tue, 26 Oct 2021 12:52:13 +0100 Subject: [PATCH 18/66] Tidy tabs --- perturbation.f90 | 32 ++++++++++++++++---------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/perturbation.f90 b/perturbation.f90 index 0353194..4a4407b 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -7480,22 +7480,22 @@ subroutine PThamiltonian_contract(jrot) ! !----------Only allocate if we are putting vectors into memory---------------! if(trim(job%diagonalizer(1:13))/='READ-ENERGIES') then - matsize = int(dimen_s,hik)*int(job%nroots(isym),hik) - if (job%verbose>=4) write(out,"('Allocate array b',i7,'x',i7,' = ',i8)") dimen_s,job%nroots(isym),matsize - allocate (a(dimen_s,job%nroots(isym)),bterm(job%nroots(isym),2),stat=alloc) - ! - a = 0 - ! - call ArrayStart('PThamiltonian_contract:b',alloc,1,kind(a),matsize) - ! - bterm = 1 - ! - if (job%verbose>=4) call MemoryReport - ! - if (job%verbose>=1) then - write (out,"(//'Size of the symmetrized hamiltonian = ',i7,' Symmetry = ',a4)") dimen_s,sym%label(isym) - endif - endif + matsize = int(dimen_s,hik)*int(job%nroots(isym),hik) + if (job%verbose>=4) write(out,"('Allocate array b',i7,'x',i7,' = ',i8)") dimen_s,job%nroots(isym),matsize + allocate (a(dimen_s,job%nroots(isym)),bterm(job%nroots(isym),2),stat=alloc) + ! + a = 0 + ! + call ArrayStart('PThamiltonian_contract:b',alloc,1,kind(a),matsize) + ! + bterm = 1 + ! + if (job%verbose>=4) call MemoryReport + ! + if (job%verbose>=1) then + write (out,"(//'Size of the symmetrized hamiltonian = ',i7,' Symmetry = ',a4)") dimen_s,sym%label(isym) + endif + endif ! call diagonalization_contract(jrot,isym,dimen_s,a,zpe,rlevel,total_roots,bterm,k_row(isym,1:dimen_s)) ! From 49ebf93ccf2b9db345b499eda00125b7352fd7d7 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 28 Oct 2021 10:58:46 +0100 Subject: [PATCH 19/66] Decouple unit tests from TROVE build --- makefile | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/makefile b/makefile index 1fa1cdd..a8b9970 100644 --- a/makefile +++ b/makefile @@ -165,18 +165,18 @@ regression-tests: $(TARGET) echo "Running regression tests" cd test/regression; ./run_regression_tests.sh -unit-tests-nompi: $(TARGET) +unit-tests-nompi: io_handler_ftn.o $(MAKE) -C test/unit LAPACK="$(LAPACK)" test_io echo "Running unit tests without MPI" test/unit/test_io ifneq ($(strip $(USE_MPI)),0) -unit-tests-mpi: $(TARGET) +unit-tests-mpi: io_handler_mpi.o $(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) +unit-tests-mpi: io_handler_mpi.o echo "Skipping unit tests with MPI (USE_MPI not set)" endif From 74247df7b2181527e425d40c9fc535c2ffa24fdb Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 28 Oct 2021 11:00:48 +0100 Subject: [PATCH 20/66] Actually error when running mpi tests without compiling with mpi --- makefile | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/makefile b/makefile index a8b9970..154c690 100644 --- a/makefile +++ b/makefile @@ -176,8 +176,8 @@ unit-tests-mpi: io_handler_mpi.o 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: io_handler_mpi.o - echo "Skipping unit tests with MPI (USE_MPI not set)" +unit-tests-mpi: + $(error set USE_MPI=1 to compile & test with MPI) endif ################################################################################ From 3fdbce4cf54a7e17b1c85f787905375a70263538 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 28 Oct 2021 14:03:02 +0100 Subject: [PATCH 21/66] Clean up initialisation of distributed array --- mpi_aux.f90 | 117 ++++++++++++++++----------------------- test/unit/test_mpi_io.pf | 26 ++++----- 2 files changed, 60 insertions(+), 83 deletions(-) diff --git a/mpi_aux.f90 b/mpi_aux.f90 index a020bc1..741fe2a 100644 --- a/mpi_aux.f90 +++ b/mpi_aux.f90 @@ -49,9 +49,10 @@ module mpi_aux integer, parameter :: MPI_OFFSET_KIND=8 #endif - integer,dimension(:),allocatable :: proc_sizes, proc_offsets, send_or_recv + integer,dimension(:),allocatable :: send_or_recv integer :: comm_size, mpi_rank - integer :: co_startdim, co_enddim + integer :: co_startdim, co_enddim, co_curr_dimen, & + co_blocksize, co_localsize logical :: comms_inited = .false., distr_inited=.false. type(MPI_Datatype) :: mpitype_column type(MPI_Datatype),dimension(:), allocatable :: mpi_blocktype @@ -211,69 +212,41 @@ subroutine co_init_distr(dimen, startdim, enddim, blocksize) integer,intent(out) :: startdim, enddim, blocksize integer :: ierr -#ifdef TROVE_USE_MPI_ - integer,dimension(:),allocatable :: starts, ends - integer :: localsize, proc_index, localsize_ + integer :: proc_index, localsize integer :: i, to_calc, ioslice_width, ioslice_maxwidth if (.not. comms_inited) stop "COMMS NOT INITIALISED" !if (distr_inited) stop "DISTRIBUTION ALREADY INITIALISED" - proc_index = mpi_rank+1 + if (dimen < comm_size) then + stop "co_init_distr: Cannot distribute matrix of dimension less than comm_size" + endif if (.not. distr_inited) then - allocate(proc_sizes(comm_size),proc_offsets(comm_size),send_or_recv(comm_size),starts(comm_size),ends(comm_size),stat=ierr) + allocate(send_or_recv(comm_size),stat=ierr) if (ierr .gt. 0) stop "CO_INIT_DISTR ALLOCATION FAILED" - else - allocate(starts(comm_size),ends(comm_size),stat=ierr) endif + co_curr_dimen = dimen ! set which dimension array we're currently distributing + if (comm_size .eq. 1) then - startdim = 1 - enddim = dimen co_startdim = 1 co_enddim = dimen - blocksize = dimen*dimen + co_blocksize = dimen*dimen send_or_recv(1) = 0 else - if (mpi_rank .eq. 0) then !root - - localsize = dimen/comm_size - localsize_ = int(1+real(dimen/comm_size)) - - starts(1) = 1 - ends(1) = localsize_ - proc_sizes(1) = localsize_*(comm_size*localsize_) - proc_offsets(1) = 0 - - do i=2,comm_size-1 - starts(i) = (i-1)*localsize_+1 - ends(i) = i*localsize_ - proc_sizes(i) = localsize_ * (comm_size*localsize_)!dimen - proc_offsets(i) = localsize_*(i-1)*(comm_size*localsize_)!dimen - end do - - starts(comm_size) = (i-1) * localsize_ + 1 - ends(comm_size) = dimen!comm_size*localsize_!dimen - proc_sizes(comm_size) = localsize_*comm_size*localsize_!dimen - - proc_offsets(comm_size) = (comm_size-1)*localsize_*(comm_size*localsize_)!dimen + localsize = 1+dimen/comm_size + co_startdim = mpi_rank*localsize + 1 + if (mpi_rank == comm_size-1) then + ! Last process gets full dimension + co_enddim = dimen + else + co_enddim = (mpi_rank+1)*localsize endif + co_blocksize = localsize*(comm_size*localsize) - call mpi_bcast(starts, comm_size, mpi_integer, 0, mpi_comm_world) - call mpi_bcast(ends, comm_size, mpi_integer, 0, mpi_comm_world) - call mpi_bcast(proc_sizes, comm_size, mpi_integer, 0, mpi_comm_world) - call mpi_bcast(proc_offsets, comm_size, mpi_integer, 0, mpi_comm_world) - - - - blocksize = proc_sizes(proc_index) - startdim = starts(proc_index) - enddim = ends(proc_index) - - co_startdim = startdim - co_enddim = enddim + co_localsize = localsize if(.not. distr_inited) then allocate(mpi_blocktype(comm_size)) @@ -292,47 +265,55 @@ subroutine co_init_distr(dimen, startdim, enddim, blocksize) endif endif + proc_index = mpi_rank+1 if (i.eq.proc_index) then send_or_recv(i) = 0 elseif ( ((i.gt.(proc_index - to_calc) .and. i.lt.proc_index)) .or. & ((proc_index-to_calc).lt.1 .and. (i-comm_size).gt.(proc_index-to_calc))) then send_or_recv(i) = 1 ! send - call co_create_type_subarray(int(1+real(dimen/comm_size)), blocksize, int(1+real(dimen/comm_size)), i, mpi_blocktype(i)) +#ifdef TROVE_USE_MPI_ + call co_create_type_subarray(co_localsize, co_blocksize, co_localsize, i, mpi_blocktype(i)) +#endif else send_or_recv(i) = -1 ! recv endif end do - endif - ioslice_width = enddim-startdim+1 - ioslice_maxwidth = (int(1+real(dimen/comm_size))) + startdim = co_startdim + enddim = co_enddim + blocksize = co_blocksize + + ioslice_width = co_enddim-co_startdim+1 +#ifdef TROVE_USE_MPI_ if (comm_size .eq. 1) then call co_create_type_column(dimen,dimen,dimen) else - call co_create_type_column(dimen, comm_size*ioslice_maxwidth, ioslice_width) - endif - - deallocate(starts,ends) - -#else - if (.not. comms_inited) stop "COMMS NOT INITIALISED" - if (.not. distr_inited) then - allocate(send_or_recv(1),stat=ierr) - if (ierr .gt. 0) stop "CO_INIT_DISTR ALLOCATION FAILED" + call co_create_type_column(ioslice_width, dimen, comm_size*co_localsize) endif - startdim = 1 - enddim = dimen - co_startdim = 1 - co_enddim = dimen - blocksize = dimen*dimen - send_or_recv(1) = 0 #endif distr_inited = .true. end subroutine co_init_distr + subroutine co_validate_dimensions(dimen) + integer, intent(in) :: dimen + + if (dimen .ne. co_curr_dimen) then + stop "Tried to use an array of different dimension to the current distributed setup" + endif + end subroutine + + subroutine co_create_distr_array(arr, dimen) + real(rk), allocatable, intent(out) :: arr(:,:) + integer, intent(in) :: dimen + + call co_validate_dimensions(dimen) + + allocate(arr(comm_size*co_localsize, co_startdim:co_startdim+co_localsize-1)) + end subroutine + ! ! Distribute the contents of an array among processes. ! If only using one process or not using MPI, do nothing. @@ -464,7 +445,7 @@ subroutine co_write_matrix_distr(x, longdim, lb, ub, outfile) end subroutine co_write_matrix_distr #ifdef TROVE_USE_MPI_ - subroutine co_create_type_column(extent, blocksize, ncols) + subroutine co_create_type_column(ncols, extent, blocksize) integer, intent(in) :: extent, blocksize, ncols integer :: ierr,writecount diff --git a/test/unit/test_mpi_io.pf b/test/unit/test_mpi_io.pf index 7529453..489621d 100644 --- a/test/unit/test_mpi_io.pf +++ b/test/unit/test_mpi_io.pf @@ -205,9 +205,9 @@ module test_mpi_io class(TestMPI), intent(inout) :: this type(ioHandlerMPI) :: ioHandler - integer :: dimen = 12 - integer :: startdim, enddim, blocksize, mdimen_p, mdimen_b, mdimen + integer :: dimen = 51 integer :: b, icoeff, jcoeff + integer :: _startdim, _enddim, _blocksize integer :: iounit, stat character(len=*), parameter :: fname = "test.dat" @@ -232,23 +232,17 @@ module test_mpi_io 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) + 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)) + call co_create_distr_array(grot_t, 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 + do icoeff=co_startdim,co_enddim + do jcoeff=((b-1)*co_localsize)+1,b*co_localsize grot_t(jcoeff,icoeff) = jcoeff*icoeff enddo enddo @@ -256,7 +250,8 @@ module test_mpi_io enddo ! Distribute between processes and save - call co_distr_data(grot_t, recvbuf, mdimen_p, startdim, enddim) + allocate(recvbuf(co_localsize,co_localsize,comm_size)) + call co_distr_data(grot_t, recvbuf, co_localsize, co_startdim, co_enddim) call ioHandler%open(fname, err, action='write', & form=form, access=access, status=status, position=position) @@ -266,13 +261,13 @@ module test_mpi_io call ioHandler%write(true_integer) ! Test writing an array - call ioHandler%write(grot_t, mdimen) + call ioHandler%write(grot_t, dimen) ! Test writing something after array call ioHandler%write(true_integer) ! Test writing another array - call ioHandler%write(grot_t, mdimen) + call ioHandler%write(grot_t, dimen) ! Test writing something after second array call ioHandler%write(true_integer) @@ -287,6 +282,7 @@ module test_mpi_io read(iounit) in_integer @assertTrue(in_integer == true_integer) + allocate(grot_full(dimen, dimen)) read(iounit) grot_full do i=1,dimen do j=1,dimen From c8a1132e3d90450e946020efd733f91b81baa1f7 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 28 Oct 2021 14:13:57 +0100 Subject: [PATCH 22/66] Create true column distributed array on the stack, not the heap --- test/unit/test_mpi_io.pf | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/test/unit/test_mpi_io.pf b/test/unit/test_mpi_io.pf index 489621d..e5de5a0 100644 --- a/test/unit/test_mpi_io.pf +++ b/test/unit/test_mpi_io.pf @@ -216,8 +216,8 @@ module test_mpi_io character(len=*), parameter :: form = "unformatted" character(len=*), parameter :: access = "sequential" + real(rk) :: grot_full(dimen, dimen) real(rk), allocatable :: grot_t(:,:) - real(rk), allocatable :: grot_full(:,:) real(rk),allocatable :: recvbuf(:,:,:) integer :: true_integer = 5, in_integer @@ -282,7 +282,6 @@ module test_mpi_io read(iounit) in_integer @assertTrue(in_integer == true_integer) - allocate(grot_full(dimen, dimen)) read(iounit) grot_full do i=1,dimen do j=1,dimen From 184554d63a8f4cfebd1a5c5436026e25c1274ae1 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 28 Oct 2021 16:20:59 +0100 Subject: [PATCH 23/66] Add test for MPI column reads --- io_handler_mpi.f90 | 13 ++--- mpi_aux.f90 | 2 +- test/unit/test_mpi_io.pf | 114 ++++++++++++++++++++++++++++++++++++--- 3 files changed, 113 insertions(+), 16 deletions(-) diff --git a/io_handler_mpi.f90 b/io_handler_mpi.f90 index d0735c3..99e324f 100644 --- a/io_handler_mpi.f90 +++ b/io_handler_mpi.f90 @@ -394,21 +394,16 @@ subroutine read2DArrayDistBlacsMPI(this, object, descr, block_type) call MPI_File_seek(this%fileh, disp+this%bookendBytes+arrSizeBytes+this%bookendBytes, MPI_SEEK_SET) end subroutine - subroutine read2DArrayDistColumnMPI(this, object, mdimen) + subroutine read2DArrayDistColumnMPI(this, object, dimen) class(ioHandlerMPI) :: this class(*), intent(in) :: object(:,:) - integer, intent(in) :: mdimen ! Dimension of entire distributed array + integer, intent(in) :: dimen ! Dimension of entire distributed array type(MPI_Datatype) :: mpiType - integer :: byteSize, globalSize, ierr, writestat, arrSizeBytes + integer :: byteSize_, globalSize, ierr, writestat, arrSizeBytes integer(kind = MPI_OFFSET_KIND) :: offset, disp - globalSize = mdimen**2 - - call getMPIVarInfo(object(1,1), byteSize, mpiType) - arrSizeBytes = globalSize*byteSize - - call writeBookendBytes(this, arrSizeBytes) + call getMPIVarInfo(object(1,1), byteSize_, mpiType) ! Get individual pointer offset call MPI_File_get_position(this%fileh, offset, ierr) diff --git a/mpi_aux.f90 b/mpi_aux.f90 index 741fe2a..f41961a 100644 --- a/mpi_aux.f90 +++ b/mpi_aux.f90 @@ -311,7 +311,7 @@ subroutine co_create_distr_array(arr, dimen) call co_validate_dimensions(dimen) - allocate(arr(comm_size*co_localsize, co_startdim:co_startdim+co_localsize-1)) + allocate(arr(comm_size*co_localsize, co_startdim:co_enddim)) end subroutine ! diff --git a/test/unit/test_mpi_io.pf b/test/unit/test_mpi_io.pf index e5de5a0..54affe6 100644 --- a/test/unit/test_mpi_io.pf +++ b/test/unit/test_mpi_io.pf @@ -21,7 +21,7 @@ module test_mpi_io integer,external :: INDXL2G logical :: is_mpi_initialised = .false. - integer, parameter :: totalTestCount = 5 ! CHANGE ME TO NUMBER OF TESTS + integer, parameter :: totalTestCount = 6 ! CHANGE ME TO NUMBER OF TESTS integer :: currentTestCount = 0 contains @@ -205,9 +205,9 @@ module test_mpi_io class(TestMPI), intent(inout) :: this type(ioHandlerMPI) :: ioHandler - integer :: dimen = 51 + integer, parameter :: dimen = 57 integer :: b, icoeff, jcoeff - integer :: _startdim, _enddim, _blocksize + integer :: startdim_, enddim_, blocksize_ integer :: iounit, stat character(len=*), parameter :: fname = "test.dat" @@ -232,7 +232,7 @@ module test_mpi_io 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) + call co_init_distr(dimen, startdim_, enddim_, blocksize_) call co_create_distr_array(grot_t, dimen) @@ -378,8 +378,110 @@ module test_mpi_io class(TestMPI), intent(inout) :: this type(ioHandlerMPI) :: ioHandler - integer, parameter :: array2DNRow = 4 - integer, parameter :: array2DNCol = 3 + integer, parameter :: dimen = 57 + integer :: b, icoeff, jcoeff + integer :: startdim_, enddim_, blocksize_ + + real(rk) :: true_array(dimen,dimen) + real(rk), allocatable :: in_array(:,:) + + integer :: true_integer = 5, 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 + integer :: ierr, rank, allocinfo = 0 + type(ErrorType) :: err + + ! Set up array + do i=1,dimen + do j=1,dimen + true_array(i,j) = i*j + end do + end do + + ! Set up MPI + call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr) + if(ierr.ne.0) print *, "Error: could not get rank" + + ! Set up 2D array block type + call co_init_distr(dimen, startdim_, enddim_, blocksize_) + call co_create_distr_array(in_array, dimen) + + ! Write test file + if(rank == 0) then + open(newunit=iounit, iostat=stat, action='write', file=fname, & + form=form, access=access, status=status, position=position) + + write(iounit) true_integer ! int + write(iounit) true_array ! 2D array + write(iounit) true_integer ! int + write(iounit) true_array ! 2D array + write(iounit) true_integer ! int + + if (stat == 0) close(iounit) + endif + + call MPI_Barrier(MPI_COMM_WORLD) + + ! Read test file + call ioHandler%open(fname, err, \ + action='read', form=form, access=access, status=status, position=position) + HANDLE_ERROR(err) + + call ioHandler%read(in_integer) + @assertTrue(in_integer == true_integer) + + call ioHandler%read(in_array, dimen) + do b=1,comm_size + if (send_or_recv(b).ge.0) then + do icoeff=co_startdim,co_enddim + do jcoeff=co_startdim,co_enddim + @assertTrue(in_array(jcoeff,icoeff) == true_array(jcoeff,icoeff)) + enddo + enddo + endif + enddo + + call ioHandler%read(true_integer) + @assertTrue(in_integer == true_integer) + + call ioHandler%read(in_array, dimen) + do b=1,comm_size + if (send_or_recv(b).ge.0) then + do icoeff=co_startdim,co_enddim + do jcoeff=co_startdim,co_enddim + @assertTrue(in_array(jcoeff,icoeff) == true_array(jcoeff,icoeff)) + enddo + enddo + endif + enddo + + call ioHandler%read(true_integer) + @assertTrue(in_integer == true_integer) + + call ioHandler%close() + + if(rank == 0) then + ! Cleanup test file + open(newunit=iounit, iostat=stat, action='read', file=fname) + if (stat == 0) close(iounit, status='delete') + endif + + end subroutine + + @test + subroutine testMPIReadColumnDistArray(this) + class(TestMPI), intent(inout) :: this + type(ioHandlerMPI) :: ioHandler + + integer, parameter :: array2DNRow = 13 + integer, parameter :: array2DNCol = 13 real(rk) :: array2D(array2DNRow,array2DNCol) real(rk), allocatable :: in_array2D(:,:) integer :: array2D_descr(9) = 0 From 0119b55514aca4a92a59a10aa4f74f737a03b033 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 4 Nov 2021 16:27:44 +0000 Subject: [PATCH 24/66] End make early if USE_MPI is anything but 0 or 1 --- makefile | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/makefile b/makefile index 154c690..9cbe009 100644 --- a/makefile +++ b/makefile @@ -14,6 +14,12 @@ COMPILER ?= intel MODE ?= release USE_MPI ?= 0 +ifneq ($(strip $(USE_MPI)),1) +ifneq ($(strip $(USE_MPI)),0) +$(error USE_MPI "$(USE_MPI)" should be set to 1 to enable MPI or 0 (default) to disable MPI.) +endif +endif + # Intel ####### ifeq ($(strip $(COMPILER)),intel) From da5887bc55b4534b3c7d991fa881cc96d3194df8 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 4 Nov 2021 16:32:38 +0000 Subject: [PATCH 25/66] Cleanup use of USE_MPI in makefile --- makefile | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/makefile b/makefile index 9cbe009..137f835 100644 --- a/makefile +++ b/makefile @@ -14,8 +14,8 @@ COMPILER ?= intel MODE ?= release USE_MPI ?= 0 -ifneq ($(strip $(USE_MPI)),1) -ifneq ($(strip $(USE_MPI)),0) +ifneq ($(USE_MPI),1) +ifneq ($(USE_MPI),0) $(error USE_MPI "$(USE_MPI)" should be set to 1 to enable MPI or 0 (default) to disable MPI.) endif endif @@ -35,7 +35,7 @@ ifeq ($(strip $(COMPILER)),intel) endif LAPACK = -mkl=parallel - ifneq ($(strip $(USE_MPI)),0) + ifeq ($(USE_MPI),1) LAPACK += -lmkl_scalapack_lp64 -lmkl_blacs_intelmpi_lp64 endif @@ -60,7 +60,7 @@ else ifeq ($(strip $(COMPILER)),gfortran) endif LAPACK = -L${MKLROOT}/lib/intel64 -Wl,--no-as-needed -lmkl_gf_lp64 -lmkl_gnu_thread -lmkl_core -lgomp -lpthread -lm -ldl - ifneq ($(strip $(USE_MPI)),0) + ifneq ($(USE_MPI),0) # Assume we're using openmpi with gfortran LAPACK += -lmkl_blacs_openmpi_lp64 -lmkl_scalapack_lp64 endif @@ -70,7 +70,7 @@ endif CPPFLAGS = -D_EXTFIELD_DEBUG_ -ifneq ($(strip $(USE_MPI)),0) +ifeq ($(USE_MPI),1) FC = mpif90 FFLAGS += -DTROVE_USE_MPI_ endif @@ -98,7 +98,7 @@ user_pot_dir=. TARGET=$(BINDIR)/$(EXE) MPI_SRCS = -ifneq ($(strip $(USE_MPI)),0) +ifeq ($(USE_MPI),1) MPI_SRCS += io_handler_mpi.f90 endif @@ -176,7 +176,7 @@ unit-tests-nompi: io_handler_ftn.o echo "Running unit tests without MPI" test/unit/test_io -ifneq ($(strip $(USE_MPI)),0) +ifeq ($(USE_MPI),1) unit-tests-mpi: io_handler_mpi.o $(MAKE) -C test/unit LAPACK="$(LAPACK)" test_mpi_io echo "Running unit tests with MPI" From 8b74b82ca79a25e0cda72324c8dded42c240a365 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 4 Nov 2021 16:35:21 +0000 Subject: [PATCH 26/66] Fix use of USE_MPI in regression test scripts --- test/regression/scripts/H2CO/run_benchmark.sh | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/test/regression/scripts/H2CO/run_benchmark.sh b/test/regression/scripts/H2CO/run_benchmark.sh index ba8db20..5acc493 100755 --- a/test/regression/scripts/H2CO/run_benchmark.sh +++ b/test/regression/scripts/H2CO/run_benchmark.sh @@ -12,7 +12,7 @@ exe=$2 # Ensure stacksize unlimited (for fortran) ulimit -d unlimited -if [ -n "${USE_MPI}" ]; then +if [[ ${USE_MPI} == 1 ]]; then echo "MPI enabled" LAUNCH="time mpirun -np $nproc --mca opal_warn_on_missing_libcuda 0" ./set_io_format.sh enable @@ -20,6 +20,7 @@ if [ -n "${USE_MPI}" ]; then else echo "MPI disabled" LAUNCH="time" + ./set_io_format.sh disable export OMP_NUM_THREADS=$nproc fi @@ -28,7 +29,7 @@ echo "Current directory: `pwd`" echo "Using ${nproc} process(es)" files_to_check=(file{1..12}) -if [[ ${USE_MPI} -ne 1 ]]; then +if [[ ${USE_MPI} == 0 ]]; then # The intensity file does not work with MPI at the moment files_to_check+=(file_intensity) fi From bc1900574fdd1a38d624724974cf86df0b20ac2f Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 4 Nov 2021 16:48:34 +0000 Subject: [PATCH 27/66] Add seek and column reading to io handlers --- io_handler_base.f90 | 16 +++++++++++++++- io_handler_ftn.f90 | 26 ++++++++++++++++++++++++++ io_handler_mpi.f90 | 16 ++++++++++++++-- 3 files changed, 55 insertions(+), 3 deletions(-) diff --git a/io_handler_base.f90 b/io_handler_base.f90 index 4b9db18..28bbd53 100644 --- a/io_handler_base.f90 +++ b/io_handler_base.f90 @@ -7,17 +7,19 @@ module io_handler_base type, abstract :: ioHandlerBase contains procedure(open), deferred :: open + procedure(seek), deferred :: seek generic :: write => writeScalar, write1DArray, write2DArray, write2DArrayDistBlacs, write2DArrayDistColumn procedure(writeScalar), deferred :: writeScalar procedure(write1DArray), deferred :: write1DArray procedure(write2DArray), deferred :: write2DArray procedure(write2DArrayDistBlacs), deferred :: write2DArrayDistBlacs procedure(write2DArrayDistColumn), deferred :: write2DArrayDistColumn - generic :: read => readScalar, read1DArray, read2DArray, read2DArrayDistBlacs + generic :: read => readScalar, read1DArray, read2DArray, read2DArrayDistBlacs, read2DArrayDistColumn procedure(readScalar), deferred :: readScalar procedure(read1DArray), deferred :: read1DArray procedure(read2DArray), deferred :: read2DArray procedure(read2DArrayDistBlacs), deferred :: read2DArrayDistBlacs + procedure(read2DArrayDistColumn), deferred :: read2DArrayDistColumn end type ioHandlerBase abstract interface @@ -83,6 +85,18 @@ subroutine read2DArrayDistBlacs(this, object, descr, block_type) integer, intent(in) :: descr(9) ! Description array outputted from co_block_type_init type(MPI_Datatype), intent(in) :: block_type end subroutine + subroutine read2DArrayDistColumn(this, object, dimen) + import ioHandlerBase + import MPI_Datatype + class(ioHandlerBase) :: this + class(*), intent(out) :: object(:,:) + integer, intent(in) :: dimen ! Dimension of entire distributed array + end subroutine + subroutine seek(this, offset) + import ioHandlerBase + class(ioHandlerBase) :: this + integer, intent(in) :: offset + end subroutine end interface private diff --git a/io_handler_ftn.f90 b/io_handler_ftn.f90 index 5f36e84..4d36abd 100644 --- a/io_handler_ftn.f90 +++ b/io_handler_ftn.f90 @@ -22,8 +22,10 @@ module io_handler_ftn procedure :: read1DArray => read1DArrayFTN procedure :: read2DArray => read2DArrayFTN procedure :: read2DArrayDistBlacs => read2DArrayDistBlacsFTN + procedure :: read2DArrayDistColumn => read2DArrayDistColumnFTN procedure :: open procedure :: close + procedure :: seek final :: destroyIoHandlerFTN end type ioHandlerFTN @@ -100,6 +102,19 @@ subroutine close(this) endif end subroutine + subroutine seek(this, offset) + class(ioHandlerFTN) :: this + INTEGER, PARAMETER :: SEEK_SET = 0, SEEK_CUR = 1, SEEK_END = 2 + integer, intent(in) :: offset + integer :: total_offset + + if (trim(this%accessVal) == "sequential") then + ! Add bookend offset + total_offset = offset + 8 + endif + call fseek(this%iounit, total_offset, SEEK_CUR) + end subroutine + subroutine writeScalarFTN(this, object) class(ioHandlerFTN) :: this class(*), intent(in) :: object @@ -260,4 +275,15 @@ subroutine read2DArrayDistBlacsFTN(this, object, descr, block_type) ! Using the fortran io_handler means array isn't distributed, just read normally call this%read2DArray(object) end subroutine + + subroutine read2DArrayDistColumnFTN(this, object, dimen) + ! read arrays distributed as columns using co_distr_data + + class(ioHandlerFTN) :: this + class(*), dimension(:,:), intent(out) :: object + integer, intent(in) :: dimen + + ! Using the fortran io_handler means array isn't distributed, just read normally + call this%read2DArray(object) + end subroutine end module diff --git a/io_handler_mpi.f90 b/io_handler_mpi.f90 index 99e324f..d7f2a32 100644 --- a/io_handler_mpi.f90 +++ b/io_handler_mpi.f90 @@ -49,6 +49,7 @@ module io_handler_mpi procedure :: read2DArrayDistColumn => read2DArrayDistColumnMPI procedure :: open procedure :: close + procedure :: seek final :: destroyIoHandlerMPI end type ioHandlerMPI @@ -137,6 +138,18 @@ subroutine close(this) ! FIXME handle error end subroutine close + subroutine seek(this, offset) + class(ioHandlerMPI) :: this + integer, intent(in) :: offset + integer(kind=MPI_OFFSET_KIND) :: total_offset + + if (trim(this%accessVal) == "sequential") then + ! Add bookend offset + total_offset = offset + 8 + endif + call MPI_File_seek(this%fileh, total_offset, MPI_SEEK_CUR) + end subroutine + subroutine getMPIVarInfo(object, byteSize, mpiType) class(*), intent(in) :: object integer, intent(out) :: byteSize @@ -192,7 +205,6 @@ subroutine writeBookendBytes(this, bytes) endif end subroutine - subroutine writeScalarMPI(this, object) class(ioHandlerMPI) :: this class(*), intent(in) :: object @@ -396,7 +408,7 @@ subroutine read2DArrayDistBlacsMPI(this, object, descr, block_type) subroutine read2DArrayDistColumnMPI(this, object, dimen) class(ioHandlerMPI) :: this - class(*), intent(in) :: object(:,:) + class(*), intent(out) :: object(:,:) integer, intent(in) :: dimen ! Dimension of entire distributed array type(MPI_Datatype) :: mpiType From ab460d8964832950dc64d05d7ced33492af588c9 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 4 Nov 2021 16:49:26 +0000 Subject: [PATCH 28/66] Save access to class in FTN io handler --- io_handler_ftn.f90 | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/io_handler_ftn.f90 b/io_handler_ftn.f90 index 4d36abd..68012fd 100644 --- a/io_handler_ftn.f90 +++ b/io_handler_ftn.f90 @@ -12,6 +12,7 @@ module io_handler_ftn integer :: iounit = 0 integer :: stat = 0 logical :: isOpen = .false. + character (len=20) :: accessVal contains procedure :: writeScalar => writeScalarFTN procedure :: write1DArray => write1DArrayFTN @@ -71,21 +72,21 @@ subroutine open(this, fname, err, action, position, status, form, access) end if if (present(access)) then - accessVal = access + this%accessVal = access else - accessVal = 'sequential' - end if + this%accessVal = 'sequential' + endif print *, "FTN: Opening ", trim(fname), " with ", & trim(action), " ", & trim(positionVal), " ", & trim(statusVal), " ", & trim(formVal), " ", & - trim(accessVal) + trim(this%accessVal) open(newunit=this%iounit, action=action, & form=formVal, position=positionVal, status=statusVal, & - access=accessVal, file=fname, iostat=this%stat) + access=this%accessVal, file=fname, iostat=this%stat) if (this%stat == 0) then this%isOpen = .true. @@ -265,7 +266,7 @@ subroutine read2DArrayFTN(this, object) end subroutine subroutine read2DArrayDistBlacsFTN(this, object, descr, block_type) - ! read arrays distributed as columns using co_distr_data + ! Read blacs-distributed arrays class(ioHandlerFTN) :: this class(*), dimension(:,:), intent(out) :: object From e33353e95fe3b5d1a864eda0985a186fa9f27e2d Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 4 Nov 2021 16:50:23 +0000 Subject: [PATCH 29/66] Remove commented out lines from perturbation.f90 --- perturbation.f90 | 5 ----- 1 file changed, 5 deletions(-) diff --git a/perturbation.f90 b/perturbation.f90 index 4a4407b..8cbec11 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -128,9 +128,7 @@ module perturbation ! type PTcontrME integer(ik) :: isize ! Number of expansion coeffs. - !real(rk),pointer :: icoeff(:,:) ! Expansion powers real(rk),pointer :: me(:,:) ! matrix elements - ! end type PTcontrME type PTcoeffT @@ -140,7 +138,6 @@ module perturbation real(rk),pointer :: coeff(:,:,:) integer(ik),pointer :: IndexQ(:,:) integer(ik),pointer :: ifromsparse(:) - !integer(ik),pointer :: itosparse(:) type(PTintcoeffs1dT),pointer :: icoeff(:) type(PTintcoeffs1dT),pointer :: iuniq(:) integer(ik),pointer :: ifield(:) @@ -156,7 +153,6 @@ module perturbation logical :: initialized = .false. type(PTcoeffs1dT),pointer :: abcissa(:) type(PTcoeffs1dT),pointer :: weight(:) - !type(PTcoeffs3dT),pointer :: deriv(:) real(rk),pointer :: poten(:) real(rk),pointer :: gvib(:,:,:) real(rk),pointer :: grot(:,:,:) @@ -171,7 +167,6 @@ module perturbation integer(ik),pointer :: nsize(:) ! number of points along each mode integer(hik) :: total_size ! total size of the dvr basis set real(ark),pointer :: drho(:) ! dvr integration step - end type PTdvrT From 8e272c5220bbe02e8ba25c3515e5541a8813ca1a Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 4 Nov 2021 17:02:58 +0000 Subject: [PATCH 30/66] Remove unecessary io handlers outside of PTrestore_rot_kinetic_matrix_elements --- perturbation.f90 | 105 +++++++++++++---------------------------------- 1 file changed, 28 insertions(+), 77 deletions(-) diff --git a/perturbation.f90 b/perturbation.f90 index 8cbec11..2814ba4 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -7333,15 +7333,14 @@ subroutine PThamiltonian_contract(jrot) real(rk) :: zpe integer :: slevel,dimen_s,max_dim,iterm,jterm,total_roots,icontr,ierr ! - integer(ik) :: iunit,unitO,unitC,rec_len,irec_len,chkptIO + integer(ik) :: unitO,unitC,rec_len,irec_len,chkptIO integer(ik) :: ncontr,maxcontr,maxcontr0 character(len=cl) :: task character(len=4) :: jchar character(len=cl) :: unitfname,filename,statusf='old',symchar logical :: only_store = .false. logical :: no_diagonalization = .false. - !AT - type(MPI_File) :: mpiiofile + integer :: startdim,enddim,localrootsize ! ! A special case when the diagonlization is to be skipped @@ -7662,10 +7661,10 @@ subroutine PThamiltonian_contract(jrot) ! task = 'top' if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,mpiiofile,dimen,& + call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,dimen,& ncontr,maxcontr) else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,iunit,dimen,ncontr,maxcontr) + call PTrestore_rot_kinetic_matrix_elements(jrot,task,dimen,ncontr,maxcontr) endif ! ! We have two calculation options: fast and cheap and slow but expensive. @@ -7684,18 +7683,18 @@ subroutine PThamiltonian_contract(jrot) ! task = 'rot' if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,mpiiofile,dimen,& + call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,dimen,& ncontr,maxcontr) else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,iunit,dimen,ncontr,maxcontr) + call PTrestore_rot_kinetic_matrix_elements(jrot,task,dimen,ncontr,maxcontr) endif ! task = 'cor' if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,mpiiofile,dimen,& + call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,dimen,& ncontr,maxcontr) else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,iunit,dimen,ncontr,maxcontr) + call PTrestore_rot_kinetic_matrix_elements(jrot,task,dimen,ncontr,maxcontr) endif ! call TimerStop('Restoring KE matrix') @@ -7712,10 +7711,10 @@ subroutine PThamiltonian_contract(jrot) ! task = 'vib' if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,mpiiofile,dimen,& + call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,dimen,& ncontr,maxcontr) else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,iunit,dimen,ncontr,maxcontr) + call PTrestore_rot_kinetic_matrix_elements(jrot,task,dimen,ncontr,maxcontr) endif call TimerStop('Restoring KE matrix') @@ -7791,10 +7790,10 @@ subroutine PThamiltonian_contract(jrot) ! task = 'top-icontr' if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,mpiiofile,dimen,& + call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,dimen,& ncontr,maxcontr) else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,iunit,dimen,ncontr,maxcontr) + call PTrestore_rot_kinetic_matrix_elements(jrot,task,dimen,ncontr,maxcontr) endif ! if (job%verbose>=5) write(out,"(' N Arrays of ',f12.5,'Gb each will be allocated (N is the number of processors)')") & @@ -7816,18 +7815,18 @@ subroutine PThamiltonian_contract(jrot) ! task = 'rot-icontr' if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,mpiiofile,dimen,& + call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,dimen,& ncontr,maxcontr) else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,iunit,dimen,ncontr,maxcontr,icontr) + call PTrestore_rot_kinetic_matrix_elements(jrot,task,dimen,ncontr,maxcontr,icontr) endif ! task = 'cor-icontr' if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,mpiiofile,dimen,& + call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,dimen,& ncontr,maxcontr) else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,iunit,dimen,ncontr,maxcontr,icontr) + call PTrestore_rot_kinetic_matrix_elements(jrot,task,dimen,ncontr,maxcontr,icontr) endif ! endif @@ -7836,10 +7835,10 @@ subroutine PThamiltonian_contract(jrot) ! task = 'vib-icontr' if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,mpiiofile,dimen,& + call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,dimen,& ncontr,maxcontr) else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,iunit,dimen,ncontr,maxcontr,icontr) + call PTrestore_rot_kinetic_matrix_elements(jrot,task,dimen,ncontr,maxcontr,icontr) endif ! endif @@ -7920,10 +7919,10 @@ subroutine PThamiltonian_contract(jrot) task = 'rot' ! if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,mpiiofile,dimen,& + call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,dimen,& ncontr,maxcontr) else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,iunit,dimen,ncontr,maxcontr) + call PTrestore_rot_kinetic_matrix_elements(jrot,task,dimen,ncontr,maxcontr) endif ! ! $omp parallel private(mat_t,alloc_p) @@ -7981,10 +7980,10 @@ subroutine PThamiltonian_contract(jrot) task = 'cor' ! if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,mpiiofile,dimen,& + call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,dimen,& ncontr,maxcontr) else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,iunit,dimen,ncontr,maxcontr) + call PTrestore_rot_kinetic_matrix_elements(jrot,task,dimen,ncontr,maxcontr) endif ! ! $omp parallel private(mat_t,alloc_p) @@ -8048,10 +8047,10 @@ subroutine PThamiltonian_contract(jrot) task = 'vib' ! if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,mpiiofile,dimen,& + call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,dimen,& ncontr,maxcontr) else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,iunit,dimen,ncontr,maxcontr) + call PTrestore_rot_kinetic_matrix_elements(jrot,task,dimen,ncontr,maxcontr) endif ! ! $omp parallel private(mat_t,alloc_p) @@ -8496,55 +8495,7 @@ end subroutine PThamiltonian_contract !!!!!!!!! MPIIO !!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine open_chkptfile_mpi(fileh, filename, mode) -#ifdef TROVE_USE_MPI_ - use mpi_f08 -#endif - use mpi_aux - - type(MPI_File),intent(inout) :: fileh - character(len=*),intent(in) :: filename, mode - -#ifdef TROVE_USE_MPI_ - integer :: amode, ierr - - select case(mode) - case('read') - amode = mpi_mode_rdonly - case('write') - amode = mpi_mode_wronly+mpi_mode_create - end select - - call MPI_File_open(mpi_comm_world, filename, amode, mpi_info_null, fileh, ierr) - if (ierr.gt.0) then - if (mpi_rank .eq. 0) write(*,*) "Error opening MPI-IO-formatted Vib. kinetic checkpoint file. ", filename - stop "MPI_PTrestore_rot_kinetic_matrix_elements - Error opening MATELEM MPI-IO input file" - endif - - !File errors indicate big trouble, so we set errors to be fatal - not likely to be recoverable - call MPI_File_set_errhandler(fileh, MPI_ERRORS_ARE_FATAL) -#endif - end subroutine open_chkptfile_mpi - - subroutine close_chkptfile_mpi(fileh) -#ifdef TROVE_USE_MPI_ - use mpi_f08 -#endif - use mpi_aux - - type(MPI_File), intent(inout) :: fileh -#ifdef TROVE_USE_MPI_ - integer :: ierr - - call mpi_file_close(fileh, ierr) - if (ierr.gt.0) then - if (mpi_rank .eq. 0) write(*,*) "Error closing MPI-IO-formatted Vib. kinetic checkpoint file." - stop "MPI_PTrestore_rot_kinetic_matrix_elements - Error closing MATELEM MPI-IO input file" - endif -#endif - end subroutine close_chkptfile_mpi - - subroutine PTrestore_rot_kinetic_matrix_elements_mpi(jrot, task, fileh, dimen, & + subroutine PTrestore_rot_kinetic_matrix_elements_mpi(jrot, task, dimen, & ncontr, maxcontr, icontr) #ifdef TROVE_USE_MPI_ use mpi_f08 @@ -8552,7 +8503,7 @@ subroutine PTrestore_rot_kinetic_matrix_elements_mpi(jrot, task, fileh, dimen, & use mpi_aux integer(ik),intent(in) :: jrot character(len=cl),intent(in) :: task - type(MPI_File),intent(inout) :: fileh + class(ioHandlerBase), allocatable :: ioHandler integer(ik),intent(in) :: dimen integer(ik),intent(inout),optional :: ncontr @@ -9186,16 +9137,16 @@ end subroutine divided_slice_close_mpi ! ! Here we restore the vibrational (J=0) matrix elements of the rotational kinetic part G_rot and G_cor ! - subroutine PTrestore_rot_kinetic_matrix_elements(jrot,task,chkptIO,dimen,ncontr,maxcontr,icontr) + subroutine PTrestore_rot_kinetic_matrix_elements(jrot,task,dimen,ncontr,maxcontr,icontr) ! integer(ik),intent(in) :: jrot character(len=cl),intent(in) :: task - integer(ik),intent(inout) :: chkptIO integer(ik),intent(in) :: dimen integer(ik),intent(inout),optional :: ncontr integer(ik),intent(inout),optional :: maxcontr integer(ik),intent(in),optional :: icontr ! + integer(ik) :: chkptIO integer(ik) :: alloc character(len=cl) :: job_is,filename character(len=18) :: buf18 From d4222a882f55095864afdde9d22a551b09f0943f Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 4 Nov 2021 18:44:32 +0000 Subject: [PATCH 31/66] Remove legacy commas --- perturbation.f90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/perturbation.f90 b/perturbation.f90 index 2814ba4..79d775d 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -11300,7 +11300,7 @@ subroutine diagonalization_contract(jrot,gamma,dimen_s,mat,zpe,rlevel,total_root ! spur = spur*exp(-beta*mat0) ! - write(out, '(/1x, a, 1x, es16.8)'), 'qpart = ', spur + write(out, '(/1x, a, 1x, es16.8)') 'qpart = ', spur ! !mat = mat / (-planck * vellgt) * (boltz * intensity%temperature) !do ielem = 1, dimen_s @@ -11313,7 +11313,7 @@ subroutine diagonalization_contract(jrot,gamma,dimen_s,mat,zpe,rlevel,total_root ! if (gamma==sym%Nrepresen) then ! - write(out, '(/1x, a, 1x, es16.8)'), 'partition function value is', job%partfunc%value + write(out, '(/1x, a, 1x, es16.8)') 'partition function value is', job%partfunc%value ! endif ! @@ -34371,7 +34371,7 @@ subroutine partfunc_matexp_taylor(dimen,m,norm_thresh,max_deg,spur_thresh,max_or ! ! perform squaring ! - write(out, '(/1x, a/1x, a, 1x, a)'), 'perform squaring', 'deg of 2', 'norm' + write(out, '(/1x, a/1x, a, 1x, a)') 'perform squaring', 'deg of 2', 'norm' ! if (job%verbose>=2) call TimerStart('Partition function my mat-exp') ! @@ -34386,13 +34386,13 @@ subroutine partfunc_matexp_taylor(dimen,m,norm_thresh,max_deg,spur_thresh,max_or ! do if (deg > max_deg) then - write(out, '(/1x, a, 1x, i3, 1x, a)'), 'max degree of 2', max_deg, 'is reached' + write(out, '(/1x, a, 1x, i3, 1x, a)') 'max degree of 2', max_deg, 'is reached' exit end if ! norm = norm / real(2**deg, kind = rk) ! - write(out, '(1x, i3, 1x, es16.8)'), deg, norm + write(out, '(1x, i3, 1x, es16.8)') deg, norm ! if (abs(norm) <= norm_thresh) exit deg = deg + 1 @@ -34450,14 +34450,14 @@ subroutine partfunc_matexp_taylor(dimen,m,norm_thresh,max_deg,spur_thresh,max_or spur = real(dimen, kind = rk) spur0 = spur ! - write(out, '(/1x, a/1x, a, 13x, a)'), 'compute exponential', 'ord', 'spur' + write(out, '(/1x, a/1x, a, 13x, a)') 'compute exponential', 'ord', 'spur' ! ! loop over Taylor series ! do iorder = iorder + 1 if (iorder > max_order) then - write(out, '(/1x, a, 1x, i3, 1x, a)'), 'max exp degree', max_order, 'is reached' + write(out, '(/1x, a, 1x, i3, 1x, a)') 'max exp degree', max_order, 'is reached' exit end if ! @@ -34694,7 +34694,7 @@ subroutine partfunc_matexp_taylor(dimen,m,norm_thresh,max_deg,spur_thresh,max_or end do !$omp end parallel do ! - write(out, '(1x, i3, 1x, es16.8)'), iorder, spur + write(out, '(1x, i3, 1x, es16.8)') iorder, spur ! if (abs(spur - spur0) <= spur_thresh) exit spur0 = spur From b3e1740a444745e330b53afd732987b006c60cf9 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 4 Nov 2021 21:07:21 +0000 Subject: [PATCH 32/66] Make bookend offset in seek more readable --- io_handler_mpi.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/io_handler_mpi.f90 b/io_handler_mpi.f90 index d7f2a32..8f30b85 100644 --- a/io_handler_mpi.f90 +++ b/io_handler_mpi.f90 @@ -144,8 +144,8 @@ subroutine seek(this, offset) integer(kind=MPI_OFFSET_KIND) :: total_offset if (trim(this%accessVal) == "sequential") then - ! Add bookend offset - total_offset = offset + 8 + ! Add two bookend offsets + total_offset = offset + 2*4 endif call MPI_File_seek(this%fileh, total_offset, MPI_SEEK_CUR) end subroutine From b6f2b43176d5edbbda78f54667f9623a0b7357e7 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 4 Nov 2021 21:23:35 +0000 Subject: [PATCH 33/66] Remove commented out code --- perturbation.f90 | 147 ----------------------------------------------- 1 file changed, 147 deletions(-) diff --git a/perturbation.f90 b/perturbation.f90 index 79d775d..cfc4768 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -9927,153 +9927,6 @@ subroutine symm_mat_element_vector(jrot,irow,ijterm,func,mat_t,no_diagonalizatio !call TimerStop('Symmetrized Hamiltonian - one column') ! end subroutine symm_mat_element_vector - - ! - ! In this version of the routine we construct the Hamiltonian matrix in symm. adapted representaion - ! for rotational basis which is not factorized with "K". - ! - !subroutine symm_mat_element_vector(jrot,irow,ijterm,func,mat_t,no_diagonalization) - - !integer(ik),intent(in) :: jrot,irow,ijterm(:,:) - !real(rk),external :: func - !real(rk),intent(out) :: mat_t(:,:,:) - !logical,optional,intent(in) :: no_diagonalization - !! - !integer(ik) :: cnu_i(0:PT%Nclasses),cnu_j(0:PT%Nclasses) - !integer(ik) :: deg_i(0:PT%Nclasses),deg_j(0:PT%Nclasses) - !real(rk) :: mat_elem - !integer(ik) :: isize,jsize,ielem,jelem - !integer(ik) :: jrow,ideg,jdeg,isym,jsym,iL,iR,iterm,jterm,icontr,jcontr - !real(rk) :: vec_i(PT%max_deg_size),vec_j(PT%max_deg_size) - - !real(rk), dimension(:,:,:), allocatable :: hcontr - - !allocate(hcontr(PT%max_deg_size,PT%max_deg_size,irow)) - !! - !mat_t = 0 - !! - !cnu_i(:) = PT%contractive_space(:,irow) - !! - !isize = PT%Index_deg(irow)%size1 - !! - !do jrow = 1,irow - !! - !if ( present(no_diagonalization).and.no_diagonalization.and.jrow/=irow ) cycle - !! - !cnu_j(:) = PT%contractive_space(:,jrow) - !! - !jsize = PT%Index_deg(jrow)%size1 - !! - !do ideg = 1,isize - !! - !deg_i(:) = PT%Index_deg(irow)%icoeffs(:,ideg) - !! - !do jdeg = 1,jsize - !! - !deg_j(:) = PT%Index_deg(jrow)%icoeffs(:,jdeg) - !! - !icontr = PT%icase2icontr(irow,ideg) - !jcontr = PT%icase2icontr(jrow,jdeg) - !! - !! Matrix elements - !! - !hcontr(ideg,jdeg,jrow) = func(icontr,jcontr,jrot,cnu_i(0),cnu_j(0),deg_i(0),deg_j(0)) - !! - !enddo - !! - !enddo - !! - !end do - - !do jrow=1,irow - !jsize = PT%Index_deg(jrow)%size1 - !do isym = 1,sym%Nrepresen - !! - !iterm = ijterm(irow,isym) - !! - !do jsym = 1,isym - !! - !jterm = ijterm(jrow,jsym) - !! - !do ielem = 1,PT%irr(isym)%N(irow) - !! - !vec_i(1:isize) = PT%irr(isym)%repres(iterm+ielem,1,1:isize) - !! - !do jelem = 1,PT%irr(jsym)%N(jrow) - !! - !vec_j(1:jsize) = PT%irr(jsym)%repres(jterm+jelem,1,1:jsize) - !! - !vec_j(1:isize) = matmul(hcontr(1:isize,1:jsize, jrow),vec_j(1:jsize)) - !! - !mat_elem = dot_product(vec_i(1:isize),vec_j(1:isize)) - !! - !if (isym==jsym) then - !! - !iL = ielem - !iR = jterm+jelem - !! - !if (iterm+ielem(10.0_rk)**(-(rk-3))) then - !! - !! We print out non-zero mat. elements between different symmetries, which have to be zero. - !! - !if (job%verbose>=6) & - !write(out,"('<',a4,2i6,'|H|',a4,2i6,'> = ',g18.10)") & - !sym%label(isym),irow,iterm+ielem,sym%label(jsym),jrow,jterm+jelem,mat_elem - !! - !! if this error is too big - we stop - !! - !if(abs(mat_elem)>1.0_rk) then - !!write(out,"(/'A non-diagonal mat. element between different symmetries:')") - !write(out,"(/'<',a4,3i6,'|H|',a4,3i6,'> = ',g18.10,a)") & - !sym%label(isym),irow,ielem,iterm+ielem,sym%label(jsym),jrow,jelem,jterm+jelem,mat_elem,& - !' Non-diagonal element (euler) between different symmetries is too large!' - !stop 'non-zero element between two symmetries - symm_mat_element_vector' - !endif - !! - !endif - !endif - !! - !enddo - !enddo - !enddo - !! - !enddo - !! - !enddo - !! - !! - !!call TimerStop('Symmetrized Hamiltonian - one column') - !! - !! - !end subroutine symm_mat_element_vector - ! ! In this version of the routine we construct the Hamiltonian matrix in symm. adapted representaion ! for rotational basis which is not factorized with "K" and using the icontr-based sorting From 4b81817047613ab03db06f43b98f590be00e593e Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Fri, 5 Nov 2021 11:14:39 +0000 Subject: [PATCH 34/66] Reader works with MPI + MPIIO for matelem.chk --- io_handler_mpi.f90 | 7 +- mpi_aux.f90 | 3 +- perturbation.f90 | 529 +++++++++++++-------------------------------- 3 files changed, 154 insertions(+), 385 deletions(-) diff --git a/io_handler_mpi.f90 b/io_handler_mpi.f90 index 8f30b85..3549642 100644 --- a/io_handler_mpi.f90 +++ b/io_handler_mpi.f90 @@ -411,17 +411,14 @@ subroutine read2DArrayDistColumnMPI(this, object, dimen) class(*), intent(out) :: object(:,:) integer, intent(in) :: dimen ! Dimension of entire distributed array - type(MPI_Datatype) :: mpiType - integer :: byteSize_, globalSize, ierr, writestat, arrSizeBytes + integer :: ierr integer(kind = MPI_OFFSET_KIND) :: offset, disp - call getMPIVarInfo(object(1,1), byteSize_, mpiType) - ! Get individual pointer offset call MPI_File_get_position(this%fileh, offset, ierr) ! Set shared pointer to individual pointer + bookend call MPI_File_seek_shared(this%fileh, offset+this%bookendBytes, MPI_SEEK_SET, ierr) - ! Write array in parallel + ! Read array in parallel MPI_WRAPPER(MPI_File_read_ordered,this%fileh,object,1,mpitype_column,MPI_STATUS_IGNORE,ierr) ! Skip over last bookend call MPI_File_seek_shared(this%fileh, int(this%bookendBytes,MPI_OFFSET_KIND), MPI_SEEK_CUR, ierr) diff --git a/mpi_aux.f90 b/mpi_aux.f90 index f41961a..33e2fb3 100644 --- a/mpi_aux.f90 +++ b/mpi_aux.f90 @@ -233,6 +233,7 @@ subroutine co_init_distr(dimen, startdim, enddim, blocksize) co_startdim = 1 co_enddim = dimen co_blocksize = dimen*dimen + co_localsize = dimen send_or_recv(1) = 0 else @@ -306,7 +307,7 @@ subroutine co_validate_dimensions(dimen) end subroutine subroutine co_create_distr_array(arr, dimen) - real(rk), allocatable, intent(out) :: arr(:,:) + real(rk), pointer, intent(out) :: arr(:,:) integer, intent(in) :: dimen call co_validate_dimensions(dimen) diff --git a/perturbation.f90 b/perturbation.f90 index cfc4768..c001b4a 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -7333,6 +7333,7 @@ subroutine PThamiltonian_contract(jrot) real(rk) :: zpe integer :: slevel,dimen_s,max_dim,iterm,jterm,total_roots,icontr,ierr ! + class(ioHandlerBase), allocatable :: kinetmatHandler integer(ik) :: unitO,unitC,rec_len,irec_len,chkptIO integer(ik) :: ncontr,maxcontr,maxcontr0 character(len=cl) :: task @@ -7661,10 +7662,10 @@ subroutine PThamiltonian_contract(jrot) ! task = 'top' if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,dimen,& + call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,kinetmatHandler,dimen,& ncontr,maxcontr) else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,dimen,ncontr,maxcontr) + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) endif ! ! We have two calculation options: fast and cheap and slow but expensive. @@ -7683,18 +7684,18 @@ subroutine PThamiltonian_contract(jrot) ! task = 'rot' if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,dimen,& + call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,kinetmatHandler,dimen,& ncontr,maxcontr) else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,dimen,ncontr,maxcontr) + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) endif ! task = 'cor' if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,dimen,& + call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,kinetmatHandler,dimen,& ncontr,maxcontr) else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,dimen,ncontr,maxcontr) + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) endif ! call TimerStop('Restoring KE matrix') @@ -7711,10 +7712,10 @@ subroutine PThamiltonian_contract(jrot) ! task = 'vib' if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,dimen,& + call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,kinetmatHandler,dimen,& ncontr,maxcontr) else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,dimen,ncontr,maxcontr) + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) endif call TimerStop('Restoring KE matrix') @@ -7790,10 +7791,10 @@ subroutine PThamiltonian_contract(jrot) ! task = 'top-icontr' if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,dimen,& + call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,kinetmatHandler,dimen,& ncontr,maxcontr) else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,dimen,ncontr,maxcontr) + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) endif ! if (job%verbose>=5) write(out,"(' N Arrays of ',f12.5,'Gb each will be allocated (N is the number of processors)')") & @@ -7815,18 +7816,18 @@ subroutine PThamiltonian_contract(jrot) ! task = 'rot-icontr' if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,dimen,& + call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,kinetmatHandler,dimen,& ncontr,maxcontr) else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,dimen,ncontr,maxcontr,icontr) + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr,icontr) endif ! task = 'cor-icontr' if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,dimen,& + call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,kinetmatHandler,dimen,& ncontr,maxcontr) else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,dimen,ncontr,maxcontr,icontr) + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr,icontr) endif ! endif @@ -7835,10 +7836,10 @@ subroutine PThamiltonian_contract(jrot) ! task = 'vib-icontr' if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,dimen,& + call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,kinetmatHandler,dimen,& ncontr,maxcontr) else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,dimen,ncontr,maxcontr,icontr) + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr,icontr) endif ! endif @@ -7919,10 +7920,10 @@ subroutine PThamiltonian_contract(jrot) task = 'rot' ! if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,dimen,& + call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,kinetmatHandler,dimen,& ncontr,maxcontr) else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,dimen,ncontr,maxcontr) + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) endif ! ! $omp parallel private(mat_t,alloc_p) @@ -7973,17 +7974,16 @@ subroutine PThamiltonian_contract(jrot) enddo ! deallocate(grot) - call Arraystop('grot-matrix') ! if (job%verbose>=4) write(out,"(' Coriolis part...')") ! task = 'cor' ! if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,dimen,& + call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,kinetmatHandler,dimen,& ncontr,maxcontr) else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,dimen,ncontr,maxcontr) + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) endif ! ! $omp parallel private(mat_t,alloc_p) @@ -8034,7 +8034,6 @@ subroutine PThamiltonian_contract(jrot) enddo ! deallocate(gcor) - call Arraystop('gcor-matrix') ! endif ! @@ -8047,10 +8046,10 @@ subroutine PThamiltonian_contract(jrot) task = 'vib' ! if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,dimen,& + call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,kinetmatHandler,dimen,& ncontr,maxcontr) else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,dimen,ncontr,maxcontr) + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) endif ! ! $omp parallel private(mat_t,alloc_p) @@ -8495,7 +8494,7 @@ end subroutine PThamiltonian_contract !!!!!!!!! MPIIO !!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine PTrestore_rot_kinetic_matrix_elements_mpi(jrot, task, dimen, & + subroutine PTrestore_rot_kinetic_matrix_elements_mpi(jrot, task, ioHandler, dimen, & ncontr, maxcontr, icontr) #ifdef TROVE_USE_MPI_ use mpi_f08 @@ -8503,51 +8502,32 @@ subroutine PTrestore_rot_kinetic_matrix_elements_mpi(jrot, task, dimen, & use mpi_aux integer(ik),intent(in) :: jrot character(len=cl),intent(in) :: task - class(ioHandlerBase), allocatable :: ioHandler + class(ioHandlerBase), allocatable, intent(inout) :: ioHandler integer(ik),intent(in) :: dimen integer(ik),intent(inout),optional :: ncontr integer(ik),intent(inout),optional :: maxcontr integer(ik),intent(in),optional :: icontr -#ifdef TROVE_USE_MPI_ - type(MPI_File) :: fileh_slice + type(ErrorType) :: err + + class(ioHandlerBase), allocatable :: sliceHandler character(len=cl) :: job_id,filename,readbuf - integer(kind=MPI_Offset_kind) :: file_offset + integer :: file_offset integer :: ierr - integer(hik) :: rootsize,rootsize_,rootsize2,rootsize2_,nprocs,tid,icontr1,icontr2 + integer(hik) :: nprocs,tid,icontr1,icontr2 integer(ik),allocatable :: imat_t(:,:) real(rk),allocatable :: mat_t(:,:),mat_(:,:) real(rk) :: f_t integer :: k1,k2,islice - !AT - integer :: localmatrix_x,localmatrix_y - integer(hik) :: localrootsize if ( trim(job%IOkinet_action)/='VIB_READ'.and.trim(job%IOkinet_action)/='READ'.and..not.job%contrci_me_fast) return if ( trim(job%IOswap_matelem)/='NONE') return - rootsize = int(ncontr*(ncontr+1)/2,hik) - rootsize_ = int(maxcontr*(maxcontr+1)/2,hik) - ! - rootsize2 = int(ncontr*ncontr,hik) - rootsize2_ = int(maxcontr*maxcontr,hik) - ! - !dimen = max(min(int(PT%Maxcontracts*job%compress),PT%Maxcontracts),1) - if (mpi_rank .eq. 0 .and. (job%verbose>=6.and.present(icontr)) ) write(out,"('icontr = ',i9)") icontr - !AT - determine task-local matrix dimensions - if (comm_size.eq.1) then - localmatrix_y = ncontr - else - localmatrix_y = int(1+real(ncontr/comm_size))*comm_size - endif - localmatrix_x = co_enddim-co_startdim+1 - localrootsize = int(localmatrix_x*localmatrix_y,hik) - select case (trim(task)) case('top') @@ -8555,70 +8535,48 @@ subroutine PTrestore_rot_kinetic_matrix_elements_mpi(jrot, task, dimen, & !TODO - MPI-compatible IOStart !call IOStart(trim(job_id),fileh) - call open_chkptfile_mpi(fileh, job%kinetmat_file, 'read') - - !Collective read woo - call MPI_File_read_all(fileh, readbuf, 7, mpi_character, mpi_status_ignore, ierr) - - if (readbuf(1:7) /= '[MPIIO]') then - if (mpi_rank .eq. 0) write(*,*) "Invalid MPIIO identifier to MPI-IO-formatted Vib. kinetic checkpoint file." - call mpi_barrier(mpi_comm_world, ierr) - stop "MPI_PTrestore_rot_kinetic_matrix_elements - bogus file format header" - endif + call openFile(ioHandler, job%kinetmat_file, err, action='read', & + position='rewind', status='old', form='unformatted') + HANDLE_ERROR(err) - call MPI_File_read_all(fileh, readbuf, 18, mpi_character, mpi_status_ignore, ierr) + call ioHandler%read(readbuf(1:18)) if (readbuf(1:18) /= 'Start Kinetic part') then - if (mpi_rank .eq. 0) write(*,*) "Invalid header to MPI-IO-formatted Vib. kinetic checkpoint file." - call mpi_barrier(mpi_comm_world, ierr) - stop "MPI_PTrestore_rot_kinetic_matrix_elements - bogus file format" + if (mpi_rank .eq. 0) write (out,"(' Vib. kinetic checkpoint file ',a,' has bogus header: ',a)") & + job%kinetmat_file,readbuf(1:18) + stop 'PTrestore_rot_kinetic_matrix_elements - bogus file format' endif - call MPI_File_read_all(fileh, ncontr, 1, mpi_integer, mpi_status_ignore, ierr) + call ioHandler%read(ncontr) if (jrot==0.and.PT%Maxcontracts/=ncontr) then if (mpi_rank .eq. 0) write (out,"(' Vib. kinetic checkpoint file ',a)") job%kinetmat_file if (mpi_rank .eq. 0) write (out,"(' Actual and stored basis sizes at J=0 do not agree ',2i9)") PT%Maxcontracts,ncontr - call mpi_barrier(mpi_comm_world, ierr) - stop 'MPI_PTrestore_rot_kinetic_matrix_elements - in file - illegal nroots ' + stop 'PTrestore_rot_kinetic_matrix_elements - in file - illegal nroots ' end if - rootsize = int(ncontr*(ncontr+1)/2,hik) - rootsize2 = int(ncontr*ncontr,hik) - if (mpi_rank .eq. 0.and.job%verbose>=6) write(out,"(/'Restore_rot_kin...: Number of elements: ',i8)") PT%Maxcontracts ! Read the indexes of the J=0 contracted basis set. if (.not.FLrotation.or.jrot==0) then - - !allocate (imat_t(0:PT%Nclasses,ncontr),stat=ierr) - !call ArrayStart('mat_t',ierr,size(imat_t),kind(imat_t)) - - call MPI_File_read_all(fileh, readbuf, 10, mpi_character, mpi_status_ignore, ierr) + call ioHandler%read(readbuf(1:10)) if (readbuf(1:10)/='icontr_cnu') then if (mpi_rank .eq. 0) write (out,"(' Vib. kinetic checkpoint file ',a,': icontr_cnu is missing ',a)") job%kinetmat_file,readbuf(1:10) - call mpi_barrier(mpi_comm_world, ierr) - stop 'MPI_PTrestore_rot_kinetic_matrix_elements - in file - icontr_cnu missing' + stop 'PTrestore_rot_kinetic_matrix_elements - in file - icontr_cnu missing' end if - file_offset = (PT%Nclasses+1)*int(ncontr,MPI_OFFSET_KIND)*mpi_int_size - call MPI_File_seek(fileh, file_offset, MPI_SEEK_CUR) + file_offset = (PT%Nclasses+1)*int(ncontr,MPI_OFFSET_KIND)*MPI_INT_SIZE + call ioHandler%seek(file_offset) - call MPI_File_read_all(fileh, readbuf, 11, mpi_character, mpi_status_ignore, ierr) + call ioHandler%read(readbuf(1:11)) if (readbuf(1:11)/='icontr_ideg') then if (mpi_rank .eq. 0) write (out,"(' Vib. kinetic checkpoint file ',a,': icontr_ideg is missing ',a)") job%kinetmat_file,readbuf(1:11) - call mpi_barrier(mpi_comm_world, ierr) - stop 'MPI_PTrestore_rot_kinetic_matrix_elements - in file - icontr_ideg missing' + stop 'PTrestore_rot_kinetic_matrix_elements - in file - icontr_ideg missing' end if - file_offset = (PT%Nclasses+1)*int(ncontr,MPI_OFFSET_KIND)*mpi_int_size - call MPI_File_seek(fileh, file_offset, MPI_SEEK_CUR) - file_offset = file_offset+file_offset+mpi_int_size+46 - call MPI_File_seek_shared(fileh, file_offset, MPI_SEEK_SET) - - !deallocate(imat_t) - + file_offset = (PT%Nclasses+1)*int(ncontr,MPI_OFFSET_KIND)*MPI_INT_SIZE + call ioHandler%seek(file_offset) else allocate (PT%icontr_cnu(0:PT%Nclasses,ncontr),PT%icontr_ideg(0:PT%Nclasses,ncontr),stat=ierr) @@ -8631,36 +8589,33 @@ subroutine PTrestore_rot_kinetic_matrix_elements_mpi(jrot, task, dimen, & allocate (PT%icontr2icase(ncontr,2),stat=ierr) call ArrayStart('PT%contractive_space',ierr,size(PT%icontr2icase),kind(PT%icontr2icase)) - call MPI_File_read_all(fileh, readbuf, 10, mpi_character, mpi_status_ignore, ierr) + call ioHandler%read(readbuf(1:10)) if (readbuf(1:10)/='icontr_cnu') then if (mpi_rank .eq. 0) write (out,"(' Vib. kinetic checkpoint file ',a,': icontr_cnu is missing ',a)") job%kinetmat_file,readbuf(1:10) - call mpi_barrier(mpi_comm_world, ierr) - stop 'MPI_PTrestore_rot_kinetic_matrix_elements - in file - icontr_cnu missing' + stop 'PTrestore_rot_kinetic_matrix_elements - in file - icontr_cnu missing' end if - call MPI_File_read_all(fileh, PT%icontr_cnu, (PT%Nclasses+1)*ncontr, mpi_integer, mpi_status_ignore, ierr) + call ioHandler%read(PT%icontr_cnu) - call MPI_File_read_all(fileh, readbuf, 11, mpi_character, mpi_status_ignore, ierr) + call ioHandler%read(readbuf(1:11)) if (readbuf(1:11)/='icontr_ideg') then if (mpi_rank .eq. 0) write (out,"(' Vib. kinetic checkpoint file ',a,': icontr_ideg is missing ',a)") job%kinetmat_file,readbuf(1:11) - call mpi_barrier(mpi_comm_world, ierr) - stop 'MPI_PTrestore_rot_kinetic_matrix_elements - in file - icontr_ideg missing' + stop 'PTrestore_rot_kinetic_matrix_elements - in file - icontr_ideg missing' end if - call MPI_File_read_all(fileh, PT%icontr_ideg, (PT%Nclasses+1)*ncontr, mpi_integer, mpi_status_ignore, ierr) + call ioHandler%read(PT%icontr_ideg) endif if (job%vib_rot_contr.and.PTvibrational_me_calc) then - call MPI_File_read_all(fileh, readbuf, 7, mpi_character, mpi_status_ignore, ierr) + call ioHandler%read(readbuf(1:7)) if (readbuf(1:7)/='vib-rot') then if (mpi_rank .eq. 0) write (out,"(' Vib. kinetic checkpoint file ',a,': label vib-rot is missing ',a)") job%kinetmat_file,readbuf(1:7) - call mpi_barrier(mpi_comm_world, ierr) - stop 'MPI_PTrestore_rot_kinetic_matrix_elements - in file - vib-rot missing' + stop 'PTrestore_rot_kinetic_matrix_elements - in file - vib-rot missing' end if - call close_chkptfile_mpi(fileh) + deallocate(ioHandler) write(job_id,"('single swap_matrix')") @@ -8669,7 +8624,9 @@ subroutine PTrestore_rot_kinetic_matrix_elements_mpi(jrot, task, dimen, & filename = trim(job%matelem_suffix)//"0"//'.chk' - call open_chkptfile_mpi(fileh, filename, 'read') + call openFile(ioHandler, filename, err, action='read', & + status='old', form='unformatted') + HANDLE_ERROR(err) endif @@ -8685,8 +8642,7 @@ subroutine PTrestore_rot_kinetic_matrix_elements_mpi(jrot, task, dimen, & if (maxcontr>ncontr) then if (mpi_rank .eq. 0) write (out,"(' Actual and stored basis sizes at J=0 do not agree (maxcontr,ncontr) ',2i8)") maxcontr,ncontr - call mpi_barrier(mpi_comm_world, ierr) - stop 'MPI_PTrestore_rot_kinetic_matrix_elements - in file - illegal ncontr ' + stop 'PTrestore_rot_kinetic_matrix_elements - in file - illegal ncontr ' end if case('rot') ! @@ -8694,32 +8650,25 @@ subroutine PTrestore_rot_kinetic_matrix_elements_mpi(jrot, task, dimen, & ! ! Read the rotational part only ! - !allocate(mat_(maxcontr,maxcontr),stat=ierr) - !call ArrayStart('PThamiltonian_contract: mat_',ierr,1,kind(mat_),rootsize2_) - ! if (.not.job%IOmatelem_split) then ! - call MPI_File_read_all(fileh, readbuf, 5, mpi_character, mpi_status_ignore, ierr) + call ioHandler%read(readbuf(1:5)) if (readbuf(1:5)/='g_rot') then if(mpi_rank .eq. 0) write (out,"(' Vib. kinetic checkpoint file ',a,': g_rot is missing ',a)") job%kinetmat_file,readbuf(1:5) - call mpi_barrier(mpi_comm_world, ierr) - stop 'MPI_PTrestore_rot_kinetic_matrix_elements - in file - g_rot missing' - end if + stop 'PTrestore_rot_kinetic_matrix_elements - in file - g_rot missing' + endif ! allocate(grot(3,3),stat=ierr) ! islice = 0 ! do k1 = 1,3 - ! do k2 = 1,3 ! islice = islice + 1 ! - allocate(grot(k1,k2)%me(localmatrix_y,co_startdim:co_enddim),stat=ierr) - call ArrayStart('grot-matrix',ierr,1,kind(f_t),localrootsize) - ! - call co_read_matrix_distr(grot(k1,k2)%me, ncontr, co_startdim, co_enddim, fileh) + call co_create_distr_array(grot(k1,k2)%me, ncontr) + call ioHandler%read(grot(k1,k2)%me, ncontr) ! enddo enddo @@ -8736,20 +8685,15 @@ subroutine PTrestore_rot_kinetic_matrix_elements_mpi(jrot, task, dimen, & ! islice = islice + 1 ! - call divided_slice_open_mpi(islice,fileh_slice,'g_rot',job%matelem_suffix) - ! - allocate(grot(k1,k2)%me(localmatrix_y,co_startdim:co_enddim),stat=ierr) - call ArrayStart('grot-matrix',ierr,1,kind(f_t),localrootsize) - ! - call co_read_matrix_distr(grot(k1,k2)%me, ncontr, co_startdim, co_enddim, fileh_slice) + call co_create_distr_array(grot(k1,k2)%me, ncontr) ! - call divided_slice_close_mpi(islice,fileh_slice,'g_rot') + call divided_slice_open_mpi(islice,sliceHandler,'g_rot',job%matelem_suffix) + call sliceHandler%read(grot(k1,k2)%me, ncontr) + call divided_slice_close_mpi(islice,sliceHandler,'g_rot') ! enddo enddo endif - !deallocate(mat_) - !call ArrayStop('PThamiltonian_contract: mat_') ! if (job%verbose>=4) write(out,"(' ...done!')") ! @@ -8762,10 +8706,9 @@ subroutine PTrestore_rot_kinetic_matrix_elements_mpi(jrot, task, dimen, & ! if (.not.job%IOmatelem_split) then ! - call MPI_File_read_all(fileh, readbuf, 5, mpi_character, mpi_status_ignore, ierr) + call ioHandler%read(readbuf(1:5)) if (readbuf(1:5)/='g_cor') then if (mpi_rank .eq. 0) write (out,"(' Vib. kinetic checkpoint file ',a,': g_cor is missing ',a)") job%kinetmat_file,readbuf(1:5) - call mpi_barrier(mpi_comm_world, ierr) stop 'MPI_PTrestore_rot_kinetic_matrix_elements - in file - g_cor missing' end if ! @@ -8776,11 +8719,9 @@ subroutine PTrestore_rot_kinetic_matrix_elements_mpi(jrot, task, dimen, & do k1 = 1,3 ! islice = islice + 1 - ! - allocate(gcor(k1)%me(localmatrix_y,co_startdim:co_enddim),stat=ierr) - call ArrayStart('gcor-matrix',ierr,1,kind(f_t),localrootsize) - ! - call co_read_matrix_distr(gcor(k1)%me, ncontr, co_startdim, co_enddim, fileh) + + call co_create_distr_array(gcor(k1)%me, ncontr) + call ioHandler%read(gcor(k1)%me, ncontr) ! enddo ! @@ -8794,22 +8735,15 @@ subroutine PTrestore_rot_kinetic_matrix_elements_mpi(jrot, task, dimen, & ! islice = islice + 1 ! - allocate(gcor(k1)%me(localmatrix_y,co_startdim:co_enddim),stat=ierr) - call ArrayStart('gcor-matrix',ierr,1,kind(f_t),localrootsize) - ! - call divided_slice_open_mpi(islice,fileh_slice,'g_cor',job%matelem_suffix) - ! - call co_read_matrix_distr(gcor(k1)%me, ncontr, co_startdim, co_enddim, fileh_slice) - ! - call divided_slice_close_mpi(islice,fileh_slice,'g_cor') + call co_create_distr_array(gcor(k1)%me, ncontr) ! + call divided_slice_open_mpi(islice,sliceHandler,'g_cor',job%matelem_suffix) + call sliceHandler%read(gcor(k1)%me, ncontr) + call divided_slice_close_mpi(islice,sliceHandler,'g_cor') enddo ! endif ! - !deallocate(mat_) - !call ArrayStop('PThamiltonian_contract: mat_') - ! if (mpi_rank .eq. 0 .and. job%verbose>=4) write(out,"(' ...done!')") ! case('vib') @@ -8818,266 +8752,75 @@ subroutine PTrestore_rot_kinetic_matrix_elements_mpi(jrot, task, dimen, & ! if (.not.job%IOmatelem_split.and.( (.not.FLrotation.or.jrot==0).and.trim(job%IOkinet_action)/='VIB_READ' ) ) then ! - !allocate(mat_t(maxcontr,maxcontr),stat=ierr) - !call ArrayStart('PThamiltonian_contract: mat_t',ierr,1,kind(mat_t),rootsize2_) - ! - call MPI_File_read_all(fileh, readbuf, 5, mpi_character, mpi_status_ignore, ierr) + call ioHandler%read(readbuf(1:5)) if (readbuf(1:5)/='g_rot') then if (mpi_rank .eq. 0) write (out,"(' Vib. kinetic checkpoint file ',a,': g_rot is missing ',a)") job%kinetmat_file,readbuf(1:5) - call mpi_barrier(mpi_comm_world, ierr) - stop 'MPI_PTrestore_rot_kinetic_matrix_elements - in file - g_rot missing' + stop 'PTrestore_rot_kinetic_matrix_elements - in file - g_rot missing' end if ! - file_offset = 9*int(ncontr,MPI_OFFSET_KIND)*ncontr*mpi_real_size - call MPI_File_seek(fileh, file_offset, MPI_SEEK_CUR) + file_offset = 9*int(ncontr,MPI_OFFSET_KIND)*ncontr*MPI_REAL_SIZE + call ioHandler%seek(file_offset) ! - call MPI_File_read_all(fileh, readbuf, 5, mpi_character, mpi_status_ignore, ierr) + call ioHandler%read(readbuf(1:5)) if (readbuf(1:5)/='g_cor') then if (mpi_rank .eq. 0) write (out,"(' Vib. kinetic checkpoint file ',a,': g_cor is missing ',a)") job%kinetmat_file,readbuf(1:5) - call mpi_barrier(mpi_comm_world, ierr) - stop 'MPI_PTrestore_rot_kinetic_matrix_elements - in file - g_cor missing' + stop 'PTrestore_rot_kinetic_matrix_elements - in file - g_cor missing' end if ! file_offset = 3*int(ncontr,MPI_OFFSET_KIND)*ncontr*mpi_real_size - call MPI_File_seek(fileh, file_offset, MPI_SEEK_CUR) - ! - !deallocate(mat_t) - !call ArrayStop('mat_t') + call ioHandler%seek(file_offset) ! endif ! - if (mpi_rank .eq. 0 .and. job%verbose>=6) write(out,"(' rootsize_,rootsize = ',2i9)") rootsize_,rootsize - ! - call MPI_File_read_all(fileh, readbuf, 4, mpi_character, mpi_status_ignore, ierr) + call ioHandler%read(readbuf(1:4)) if (readbuf(1:4)/='hvib') then if (mpi_rank .eq. 0) write (out,"(' Vib. kinetic checkpoint file ',a,': hvib is missing ',a)") job%kinetmat_file,readbuf(1:4) if (mpi_rank .eq. 0 .and. readbuf(1:4)=='g_ro') then write (out,"(' Most likely non-divided chk-points used with MATELEM READ SPLIT')") write (out,"(' Re-do MATELEM SAVE SPLIT or use MATELEM SPLIT READ')") endif - call mpi_barrier(mpi_comm_world, ierr) - stop 'MPI_PTrestore_rot_kinetic_matrix_elements - in file - hvib or End missing' + stop 'PTrestore_rot_kinetic_matrix_elements - in file - hvib or End missing' end if + + call co_create_distr_array(hvib%me, ncontr) ! - !allocate(mat_(maxcontr,maxcontr),stat=ierr) - !call ArrayStart('PThamiltonian_contract: mat_',ierr,1,kind(mat_),rootsize2_) - ! - allocate(hvib%me(localmatrix_y,co_startdim:co_enddim),stat=ierr) - call ArrayStart('hvib-matrix',ierr,1,kind(f_t),localrootsize) - ! - call co_read_matrix_distr(hvib%me, ncontr, co_startdim, co_enddim, fileh) - !file_offset = int(ncontr,MPI_OFFSET_KIND)*ncontr*mpi_real_size - !call MPI_File_seek(fileh, file_offset, MPI_SEEK_CUR) - !call MPI_File_read_all(fileh, mat_(1:ncontr,1:ncontr), ncontr*ncontr, mpi_double_precision, mpi_status_ignore, ierr) - ! - !hvib%me(1:ncontr,1:ncontr) = mat_(1:ncontr,1:ncontr) - ! - !deallocate(mat_) - !call ArrayStop('PThamiltonian_contract: mat_') - ! - call MPI_File_read_all(fileh, readbuf, 16, mpi_character, mpi_status_ignore, ierr) + call ioHandler%read(hvib%me, ncontr) + + call ioHandler%read(readbuf(1:16)) if (readbuf(1:16)/='End Kinetic part') then if (mpi_rank .eq. 0) write (out,"(' Vib. kinetic checkpoint file ',a,' has bogus footer: ',a)") job%kinetmat_file,readbuf(1:16) - call mpi_barrier(mpi_comm_world, ierr) - stop 'MPI_PTrestore_rot_kinetic_matrix_elements - bogus file format' + stop 'PTrestore_rot_kinetic_matrix_elements - bogus file format' end if ! - call close_chkptfile_mpi(fileh) + deallocate(ioHandler) ! if (mpi_rank .eq. 0 .and. job%verbose>=4) write(out,"(' ...done!')") ! case('top-icontr') write(*,*) "CASE TOP-ICONTR" - !! ! - !! nprocs = 1 - !! tid = 0 - !! !$omp parallel private(tid) - !! tid = omp_get_thread_num() - !! if (tid==0) then - !! nprocs = omp_get_num_threads() - !! endif - !! !$omp end parallel - !! ! - !! if (FLrotation.and.jrot/=0) then - !! ! - !! allocate(grot(3,3),stat=ierr) - !! ! - !! rootsize2_ = int(maxcontr,hik)*int(PT%max_deg_size,hik)*9_hik*int(nprocs,hik) - !! call ArrayStart('PThamiltonian_contract: grot',ierr,1,rk,rootsize2_) - !! ! - !! allocate(gcor(3),stat=ierr) - !! rootsize2_ = int(maxcontr,hik)*int(PT%max_deg_size,hik)*int(PT%Nmodes,hik)*3_hik*int(nprocs,hik) - !! call ArrayStart('PThamiltonian_contract: grot',ierr,1,rk,rootsize2_) - !! ! - !! if (job%vib_rot_contr) then - !! ! - !! do islice = 1,9+3*PT%Nmodes - !! call divided_slice_open_vib_rot(islice,job%matelem_suffix) - !! enddo - !! ! - !! endif - !! ! - !! endif - !! ! + ! TODO MPI case('rot-icontr') ! rotational part for the vib-rot contraction scheme write(*,*) "CASE ROT-ICONTR" - !! ! - !! ! Read the rotational part only - !! ! - !! if (.not.job%IOmatelem_split ) then - !! ! - !! write (out,"('PTrestore_rot_kinetic_matrix_elements: vib-rot can be used with MATELEM SAVE SPLIT only ')") - !! stop 'PTrestore_rot_kinetic_matrix_elements: vib-rot can be used with SPLIT only' - !! ! - !! endif - !! ! - !! if (.not.job%vib_rot_contr) return - !! ! - !! icontr1 = PT%Ncontr02icase0(icontr,1) - !! icontr2 = PT%Ncontr02icase0(icontr,2) - !! ! - !! islice = 0 - !! ! - !! do k1 = 1,3 - !! do k2 = 1,3 - !! ! - !! islice = islice + 1 - !! ! - !! nullify(grot(k1,k2)%me) - !! ! - !! if (associated(grot(k1,k2)%me)) deallocate(grot(k1,k2)%me) - !! ! - !! allocate(grot(k1,k2)%me(maxcontr,icontr1:icontr2),stat=ierr) - !! ! - !! write(job_is,"('single swap_matrix #',i8)") islice - !! call IOStart(trim(job_is),chkptIO_) - !! ! - !! read(chkptIO_) grot(k1,k2)%me - !! ! - !! enddo - !! enddo - !! ! + ! TODO MPI case('cor-icontr') ! corriolis part for the vib-rot contraction scheme write(*,*) "CASE COR-ICONTR" - !! ! - !! ! Read the Corriolis part only - !! ! - !! ! - !! if (.not.job%IOmatelem_split ) then - !! ! - !! write (out,"('PTrestore_rot_kinetic_matrix_elements: vib-rot can be used with MATELEM SAVE SPLIT only ')") - !! stop 'PTrestore_rot_kinetic_matrix_elements: vib-rot can be used with SPLIT only' - !! ! - !! endif - !! ! - !! if (.not.job%vib_rot_contr) then - !! ! - !! write (out,"('PTrestore_rot_kinetic_matrix_elements: vib-rot can be used with cor-icontr only ')") - !! stop 'PTrestore_rot_kinetic_matrix_elements: vib-rot can be used with cor-icontr only' - !! ! - !! endif - !! ! - !! icontr1 = PT%Ncontr02icase0(icontr,1) - !! icontr2 = PT%Ncontr02icase0(icontr,2) - !! ! - !! islice = 9 - !! ! - !! do k1 = 1,3 - !! ! - !! islice = islice + 1 - !! ! - !! nullify(gcor(k1)%me) - !! ! - !! if (associated(gcor(k1)%me)) deallocate(gcor(k1)%me) - !! ! - !! allocate(gcor(k1)%me(maxcontr,icontr1:icontr2),stat=ierr) - !! ! - !! write(job_is,"('single swap_matrix #',i8)") islice - !! call IOStart(trim(job_is),chkptIO_) - !! ! - !! read(chkptIO_) gcor(k1)%me - !! ! - !! enddo - !! ! + ! TODO MPI case('vib-icontr') ! vibrational part for the vib-rot contraction scheme write(*,*) "CASE VIB-ICONTR" - !! ! - !! ! - !! !if (job%verbose>=4.and.irow==0) write(out,"(' Read and process vibrational part...')") - !! ! - !! if (.not.job%IOmatelem_split.and.( (.not.FLrotation.or.jrot==0).and.trim(job%IOkinet_action)/='VIB_READ' ) ) then - !! ! - !! if (job%vib_rot_contr) then - !! write (out,"('PTrestore_rot_kinetic_matrix_elements: vib-rot can be used with MATELEM SAVE SPLIT only ')") - !! stop 'PTrestore_rot_kinetic_matrix_elements: vib-rot can be used with SPLIT only' - !! endif - !! ! - !! endif - !! ! - !! if (icontr==1) then - !! ! - !! read(chkptIO) readbuf(1:4) - !! if (readbuf(1:4)/='hvib') then - !! write (out,"(' Vib. kinetic checkpoint file ',a,': hvib is missing ',a)") job%kinetmat_file,readbuf(1:4) - !! if (readbuf(1:4)=='g_ro') write (out,"(' Most likely non-divided chk-points used with MATELEM READ DIVIDED')") - !! write (out,"(' Re-do MATELEM SAVE DIVIDE or use MATELEM READ!')") - !! stop 'PTrestore_rot_kinetic_matrix_elements - in file - hvib or End missing' - !! end if - !! ! - !! endif - !! ! - !! if (associated(hvib%me)) deallocate(hvib%me) - !! ! - !! call ArrayStart('hvib-matrix',0,1,4) - !! call ArrayStart('grot-matrix',0,1,4) - !! call ArrayStart('gcor-matrix',0,1,4) - !! call ArrayStop('hvib-matrix') - !! call ArrayStop('grot-matrix') - !! call ArrayStop('gcor-matrix') - !! ! - !! icontr1 = PT%Ncontr02icase0(icontr,1) - !! icontr2 = PT%Ncontr02icase0(icontr,2) - !! ! - !! if (job%verbose>=6) write(out,"('allocate hvib for ',i9,' x ',i8,' -> ',i8)") maxcontr,icontr1,icontr2 - !! ! - !! allocate(hvib%me(maxcontr,icontr1:icontr2),stat=ierr) - !! call ArrayStart('hvib-matrix',ierr,1,kind(f_t),rootsize2_) - !! ! - !! read(chkptIO) hvib%me - !! ! - !! maxcontr0 = size(PT%Ncontr02icase0,dim=1) - !! ! - !! if (icontr==maxcontr0) then - !! ! - !! read(chkptIO) readbuf(1:4) - !! if (readbuf(1:4)/='hvib') then - !! write (out,"(' Vib. kinetic checkpoint file ',a,' has bogus footer: ',a)") job%kinetmat_file,readbuf(1:16) - !! stop 'PTrestore_rot_kinetic_matrix_elements - bogus file format' - !! end if - !! ! - !! close(chkptIO,status='keep') - !! ! - !! if (job%verbose>=4) write(out,"(' ...done!')") - !! ! - !! endif - !! ! + ! TODO MPI end select -#endif end subroutine - subroutine divided_slice_open_mpi(islice,fileh,chkpt_type,suffix) -#ifdef TROVE_USE_MPI_ - use mpi_f08 -#endif + subroutine divided_slice_open_mpi(islice,sliceHandler,chkpt_type,suffix) use mpi_aux implicit none integer(ik),intent(in) :: islice - type(MPI_File),intent(inout) :: fileh + class(ioHandlerBase), allocatable, intent(out) :: sliceHandler character(len=*),intent(in) :: chkpt_type,suffix -#ifdef TROVE_USE_MPI_ integer(ik) :: ilen character(len=cl) :: readbuf,filename,jchar + type(ErrorType) :: err integer :: ierr if (.not.job%IOmatelem_split) return @@ -9090,45 +8833,40 @@ subroutine divided_slice_open_mpi(islice,fileh,chkpt_type,suffix) ! filename = trim(suffix)//trim(adjustl(jchar))//'.chk' ! - call open_chkptfile_mpi(fileh, filename, 'read') + call openFile(sliceHandler, filename, err, action='read', & + position='rewind', status='old', form='unformatted') + HANDLE_ERROR(err) ! ilen = LEN_TRIM(chkpt_type) ! - call MPI_File_read_all(fileh, readbuf, ilen, mpi_character, mpi_status_ignore, ierr) + call sliceHandler%read(readbuf(1:ilen)) if ( trim(readbuf(1:ilen))/=trim(chkpt_type) ) then - if (mpi_rank .eq. 0) write (out,"(' [MPI] kinetic checkpoint slice ',a20,': header is missing or wrong',a)") filename,readbuf(1:ilen) - stop 'PTrestore_rot_kinetic_matrix_elements_mpi - in slice - header missing or wrong' + if (mpi_rank .eq. 0) write (out,"('divided_slice_open, kinetic checkpoint slice ',a20,': header is missing or wrong',a)") filename,readbuf(1:ilen) + stop 'PTrestore_rot_kinetic_matrix_elements- in slice - header missing or wrong' end if -#endif end subroutine divided_slice_open_mpi - subroutine divided_slice_close_mpi(islice,fileh,chkpt_type) -#ifdef TROVE_USE_MPI_ - use mpi_f08 -#endif - + subroutine divided_slice_close_mpi(islice,sliceHandler,chkpt_type) use mpi_aux integer(ik),intent(in) :: islice - type(MPI_File),intent(inout) :: fileh + class(ioHandlerBase), allocatable, intent(inout) :: sliceHandler character(len=*),intent(in) :: chkpt_type -#ifdef TROVE_USE_MPI_ integer(ik) :: ilen character(len=cl) :: readbuf + type(ErrorType) :: err integer :: ierr if (.not.job%IOmatelem_split) return ! ilen = LEN_TRIM(chkpt_type) ! - call MPI_File_read_all(fileh, readbuf, ilen, mpi_character, mpi_status_ignore, ierr) + call sliceHandler%read(readbuf(1:ilen)) if ( trim(readbuf(1:ilen))/=trim(chkpt_type) ) then - if(mpi_rank .eq. 0) write (out,"(' divided_slice_close_mpi, kinetic checkpoint slice: footer is missing or wrong',a)") readbuf(1:ilen) - stop 'divided_slice_close_mpi - in slice - footer missing or wrong' + if(mpi_rank .eq. 0) write (out,"('divided_slice_close, kinetic checkpoint slice: footer is missing or wrong',a)") readbuf(1:ilen) + stop 'divided_slice_close - in slice - footer missing or wrong' end if - ! - call close_chkptfile_mpi(fileh) -#endif + deallocate(sliceHandler) end subroutine divided_slice_close_mpi !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -9137,10 +8875,11 @@ end subroutine divided_slice_close_mpi ! ! Here we restore the vibrational (J=0) matrix elements of the rotational kinetic part G_rot and G_cor ! - subroutine PTrestore_rot_kinetic_matrix_elements(jrot,task,dimen,ncontr,maxcontr,icontr) + subroutine PTrestore_rot_kinetic_matrix_elements(jrot,task,ioHandler,dimen,ncontr,maxcontr,icontr) ! integer(ik),intent(in) :: jrot character(len=cl),intent(in) :: task + class(ioHandlerBase), allocatable, intent(inout) :: ioHandler integer(ik),intent(in) :: dimen integer(ik),intent(inout),optional :: ncontr integer(ik),intent(inout),optional :: maxcontr @@ -9900,6 +9639,34 @@ subroutine symm_mat_element_vector(jrot,irow,ijterm,func,mat_t,no_diagonalizatio ! if(abs(mat_elem)>1.0_rk) then !write(out,"(/'Non-diagonal element between different symmetries:')") + + !! DEBUG STUFF DELETEME + ideg = 1 + jdeg = 1 + deg_i(:) = PT%Index_deg(irow)%icoeffs(:,ideg) + deg_j(:) = PT%Index_deg(jrow)%icoeffs(:,jdeg) + + icontr = PT%icase2icontr(irow,ideg) + jcontr = PT%icase2icontr(jrow,jdeg) + + cnu_j(:) = PT%contractive_space(:,jrow) + + k_i = PT%rot_index(cnu_i(0),deg_i(0))%k + k_j = PT%rot_index(cnu_j(0),deg_j(0))%k + tau_i = PT%rot_index(cnu_i(0),deg_i(0))%tau + tau_j = PT%rot_index(cnu_j(0),deg_j(0))%tau + print *, icontr,jcontr,jrot,k_i,k_j,tau_i,tau_j + print *, func(icontr,jcontr,jrot,k_i,k_j,tau_i,tau_j) + + do k_j = 1,3 + do k_i = 1,k_j + ! + print *, grot(k_i,k_j)%me(icontr,jcontr) + ! + enddo + enddo + !! DEBUG STUFF DELETEME + write(0,"(/'<',a4,2i6,'|H|',a4,2i6,'> = ',g18.10,a)") & sym%label(isym),irow,iterm+ielem,sym%label(jsym),jrow,jterm+jelem,mat_elem,& 'Non-diagonal element between different symmetries is too large! (k)' @@ -16025,8 +15792,8 @@ subroutine PTcontracted_matelem_class(jrot) ! ! Prepare the checkpoint file ! - job_is ='Vib. matrix elements of the rot. kinetic part' - call IOStart(trim(job_is),chkptIO) + !job_is ='Vib. matrix elements of the rot. kinetic part' + !call IOStart(trim(job_is),chkptIO) ! call openFile(ioHandler, job%kinetmat_file, err, action='write', & position='rewind', status='replace', form='unformatted') @@ -16266,6 +16033,8 @@ subroutine PTcontracted_matelem_class(jrot) if (trim(job%IOkinet_action)=='SAVE') then if (job%IOmatelem_split) then ! + ! TODO fix MPIIO matelem split + stop "Split not implemented yet - TODO" if (trim(job%kinetmat_format).eq.'MPIIO') then call write_divided_slice_mpi(islice,'g_rot',job%matelem_suffix,mdimen,grot_t) else @@ -29230,6 +28999,8 @@ subroutine PTTest_eigensolution(jmin,jmax) integer(ik) :: iunit integer(ik) :: ncontr,maxcontr character(len=cl) :: task + ! + class(ioHandlerBase), allocatable :: ioHandler if (job%verbose>=2) write (out,"(//'Test the read/write procedure of the eigenvectors and all auxiliary information.')") @@ -29608,7 +29379,7 @@ subroutine PTTest_eigensolution(jmin,jmax) !call restore_vib_matrix_elements ! task = 'top' - call PTrestore_rot_kinetic_matrix_elements(j,task,iunit,ncontr,maxcontr) + call PTrestore_rot_kinetic_matrix_elements(j,task,ioHandler,ncontr,maxcontr) ! ! obtain the rotational matrix elements ! From f926cd6935f97213565f72984b7c99167e61f1cd Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Fri, 5 Nov 2021 11:25:05 +0000 Subject: [PATCH 35/66] Remove debug code --- io_handler_ftn.f90 | 2 -- perturbation.f90 | 28 ---------------------------- 2 files changed, 30 deletions(-) diff --git a/io_handler_ftn.f90 b/io_handler_ftn.f90 index 68012fd..d599a11 100644 --- a/io_handler_ftn.f90 +++ b/io_handler_ftn.f90 @@ -213,8 +213,6 @@ subroutine readScalarFTN(this, object) type is (complex(kind=8)) read(this%iounit) object type is (character(len=*)) - !print *, object - !stop "DEBUG readScalarFTN" read(this%iounit) object class default stop "ioHandlerFTN%readScalarFTN: Tried to read unsupported type" diff --git a/perturbation.f90 b/perturbation.f90 index c001b4a..62ed24a 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -9639,34 +9639,6 @@ subroutine symm_mat_element_vector(jrot,irow,ijterm,func,mat_t,no_diagonalizatio ! if(abs(mat_elem)>1.0_rk) then !write(out,"(/'Non-diagonal element between different symmetries:')") - - !! DEBUG STUFF DELETEME - ideg = 1 - jdeg = 1 - deg_i(:) = PT%Index_deg(irow)%icoeffs(:,ideg) - deg_j(:) = PT%Index_deg(jrow)%icoeffs(:,jdeg) - - icontr = PT%icase2icontr(irow,ideg) - jcontr = PT%icase2icontr(jrow,jdeg) - - cnu_j(:) = PT%contractive_space(:,jrow) - - k_i = PT%rot_index(cnu_i(0),deg_i(0))%k - k_j = PT%rot_index(cnu_j(0),deg_j(0))%k - tau_i = PT%rot_index(cnu_i(0),deg_i(0))%tau - tau_j = PT%rot_index(cnu_j(0),deg_j(0))%tau - print *, icontr,jcontr,jrot,k_i,k_j,tau_i,tau_j - print *, func(icontr,jcontr,jrot,k_i,k_j,tau_i,tau_j) - - do k_j = 1,3 - do k_i = 1,k_j - ! - print *, grot(k_i,k_j)%me(icontr,jcontr) - ! - enddo - enddo - !! DEBUG STUFF DELETEME - write(0,"(/'<',a4,2i6,'|H|',a4,2i6,'> = ',g18.10,a)") & sym%label(isym),irow,iterm+ielem,sym%label(jsym),jrow,jterm+jelem,mat_elem,& 'Non-diagonal element between different symmetries is too large! (k)' From 3af457d54a0f2d0e4ee16b107f8f7d4f26879285 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Fri, 5 Nov 2021 11:41:55 +0000 Subject: [PATCH 36/66] Ensure there's something to seek over when seeking through a file --- io_handler_ftn.f90 | 6 +++--- io_handler_mpi.f90 | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/io_handler_ftn.f90 b/io_handler_ftn.f90 index d599a11..ee7bc06 100644 --- a/io_handler_ftn.f90 +++ b/io_handler_ftn.f90 @@ -109,9 +109,9 @@ subroutine seek(this, offset) integer, intent(in) :: offset integer :: total_offset - if (trim(this%accessVal) == "sequential") then - ! Add bookend offset - total_offset = offset + 8 + if (trim(this%accessVal) == "sequential" .and. offset .ne. 0) then + ! Add two bookend offsets + total_offset = offset + 2*4 endif call fseek(this%iounit, total_offset, SEEK_CUR) end subroutine diff --git a/io_handler_mpi.f90 b/io_handler_mpi.f90 index 3549642..29403dd 100644 --- a/io_handler_mpi.f90 +++ b/io_handler_mpi.f90 @@ -143,7 +143,7 @@ subroutine seek(this, offset) integer, intent(in) :: offset integer(kind=MPI_OFFSET_KIND) :: total_offset - if (trim(this%accessVal) == "sequential") then + if (trim(this%accessVal) == "sequential" .and. offset .ne. 0) then ! Add two bookend offsets total_offset = offset + 2*4 endif From 10c9b46342c4e71f345d195fa7300c8b8f59fa4f Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Fri, 5 Nov 2021 11:48:50 +0000 Subject: [PATCH 37/66] Remove mpi from PTrestore... --- perturbation.f90 | 3 --- 1 file changed, 3 deletions(-) diff --git a/perturbation.f90 b/perturbation.f90 index 62ed24a..825e472 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -8496,9 +8496,6 @@ end subroutine PThamiltonian_contract subroutine PTrestore_rot_kinetic_matrix_elements_mpi(jrot, task, ioHandler, dimen, & ncontr, maxcontr, icontr) -#ifdef TROVE_USE_MPI_ - use mpi_f08 -#endif use mpi_aux integer(ik),intent(in) :: jrot character(len=cl),intent(in) :: task From de6e11fbc8a88f53b067abc1b7df458791c2b143 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Fri, 5 Nov 2021 12:10:42 +0000 Subject: [PATCH 38/66] Fix error messages in PTstore_icontr_cnu --- perturbation.f90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/perturbation.f90 b/perturbation.f90 index 825e472..453dbd9 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -34395,7 +34395,7 @@ subroutine PTstore_icontr_cnu(Maxcontracts,ioHandler,dir) 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 ' + stop 'PTstore_icontr_cnu - in file - illegal nroots ' end if ! allocate (imat_t(0:PT%Nclasses,ncontr),stat=alloc) @@ -34404,7 +34404,7 @@ subroutine PTstore_icontr_cnu(Maxcontracts,ioHandler,dir) 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' + stop 'PTstore_icontr_cnu - in file - icontr_cnu missing' end if ! call ioHandler%read(imat_t(0:PT%Nclasses,1:ncontr)) @@ -34412,7 +34412,7 @@ subroutine PTstore_icontr_cnu(Maxcontracts,ioHandler,dir) 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' + stop 'PTstore_icontr_cnu - in file - icontr_ideg missing' end if ! call ioHandler%read(imat_t(0:PT%Nclasses,1:ncontr)) From e61da6b9389b25a74a90590a8d60e5b1ddacb727 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Fri, 5 Nov 2021 15:04:56 +0000 Subject: [PATCH 39/66] Fix MPI_INT_SIZE when mpi not enabled --- perturbation.f90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/perturbation.f90 b/perturbation.f90 index 453dbd9..3122a93 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -8563,7 +8563,7 @@ subroutine PTrestore_rot_kinetic_matrix_elements_mpi(jrot, task, ioHandler, dime stop 'PTrestore_rot_kinetic_matrix_elements - in file - icontr_cnu missing' end if - file_offset = (PT%Nclasses+1)*int(ncontr,MPI_OFFSET_KIND)*MPI_INT_SIZE + file_offset = (PT%Nclasses+1)*int(ncontr,MPI_OFFSET_KIND)*sizeof(0) call ioHandler%seek(file_offset) call ioHandler%read(readbuf(1:11)) @@ -8572,7 +8572,7 @@ subroutine PTrestore_rot_kinetic_matrix_elements_mpi(jrot, task, ioHandler, dime stop 'PTrestore_rot_kinetic_matrix_elements - in file - icontr_ideg missing' end if - file_offset = (PT%Nclasses+1)*int(ncontr,MPI_OFFSET_KIND)*MPI_INT_SIZE + file_offset = (PT%Nclasses+1)*int(ncontr,MPI_OFFSET_KIND)*sizeof(0) call ioHandler%seek(file_offset) else @@ -8706,7 +8706,7 @@ subroutine PTrestore_rot_kinetic_matrix_elements_mpi(jrot, task, ioHandler, dime call ioHandler%read(readbuf(1:5)) if (readbuf(1:5)/='g_cor') then if (mpi_rank .eq. 0) write (out,"(' Vib. kinetic checkpoint file ',a,': g_cor is missing ',a)") job%kinetmat_file,readbuf(1:5) - stop 'MPI_PTrestore_rot_kinetic_matrix_elements - in file - g_cor missing' + stop 'PTrestore_rot_kinetic_matrix_elements - in file - g_cor missing' end if ! allocate(gcor(3),stat=ierr) @@ -8755,7 +8755,7 @@ subroutine PTrestore_rot_kinetic_matrix_elements_mpi(jrot, task, ioHandler, dime stop 'PTrestore_rot_kinetic_matrix_elements - in file - g_rot missing' end if ! - file_offset = 9*int(ncontr,MPI_OFFSET_KIND)*ncontr*MPI_REAL_SIZE + file_offset = 9*int(ncontr,MPI_OFFSET_KIND)*ncontr*sizeof(0.0_rk) call ioHandler%seek(file_offset) ! call ioHandler%read(readbuf(1:5)) @@ -8764,7 +8764,7 @@ subroutine PTrestore_rot_kinetic_matrix_elements_mpi(jrot, task, ioHandler, dime stop 'PTrestore_rot_kinetic_matrix_elements - in file - g_cor missing' end if ! - file_offset = 3*int(ncontr,MPI_OFFSET_KIND)*ncontr*mpi_real_size + file_offset = 3*int(ncontr,MPI_OFFSET_KIND)*ncontr*sizeof(0.0_rk) call ioHandler%seek(file_offset) ! endif From 61d812db4fcdfd7fe7993330b59a0dedff5b2603 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Mon, 8 Nov 2021 12:00:35 +0000 Subject: [PATCH 40/66] Rename PTrestore function --- perturbation.f90 | 28 ++++++++++++++-------------- 1 file changed, 14 insertions(+), 14 deletions(-) diff --git a/perturbation.f90 b/perturbation.f90 index 3122a93..b1c038f 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -7662,7 +7662,7 @@ subroutine PThamiltonian_contract(jrot) ! task = 'top' if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,kinetmatHandler,dimen,& + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,& ncontr,maxcontr) else call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) @@ -7684,7 +7684,7 @@ subroutine PThamiltonian_contract(jrot) ! task = 'rot' if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,kinetmatHandler,dimen,& + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,& ncontr,maxcontr) else call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) @@ -7692,7 +7692,7 @@ subroutine PThamiltonian_contract(jrot) ! task = 'cor' if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,kinetmatHandler,dimen,& + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,& ncontr,maxcontr) else call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) @@ -7712,7 +7712,7 @@ subroutine PThamiltonian_contract(jrot) ! task = 'vib' if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,kinetmatHandler,dimen,& + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,& ncontr,maxcontr) else call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) @@ -7791,7 +7791,7 @@ subroutine PThamiltonian_contract(jrot) ! task = 'top-icontr' if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,kinetmatHandler,dimen,& + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,& ncontr,maxcontr) else call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) @@ -7816,7 +7816,7 @@ subroutine PThamiltonian_contract(jrot) ! task = 'rot-icontr' if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,kinetmatHandler,dimen,& + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,& ncontr,maxcontr) else call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr,icontr) @@ -7824,7 +7824,7 @@ subroutine PThamiltonian_contract(jrot) ! task = 'cor-icontr' if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,kinetmatHandler,dimen,& + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,& ncontr,maxcontr) else call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr,icontr) @@ -7836,7 +7836,7 @@ subroutine PThamiltonian_contract(jrot) ! task = 'vib-icontr' if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,kinetmatHandler,dimen,& + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,& ncontr,maxcontr) else call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr,icontr) @@ -7920,7 +7920,7 @@ subroutine PThamiltonian_contract(jrot) task = 'rot' ! if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,kinetmatHandler,dimen,& + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,& ncontr,maxcontr) else call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) @@ -7980,7 +7980,7 @@ subroutine PThamiltonian_contract(jrot) task = 'cor' ! if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,kinetmatHandler,dimen,& + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,& ncontr,maxcontr) else call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) @@ -8046,7 +8046,7 @@ subroutine PThamiltonian_contract(jrot) task = 'vib' ! if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements_mpi(jrot,task,kinetmatHandler,dimen,& + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,& ncontr,maxcontr) else call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) @@ -8494,7 +8494,7 @@ end subroutine PThamiltonian_contract !!!!!!!!! MPIIO !!!!!!!!!!!!!! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine PTrestore_rot_kinetic_matrix_elements_mpi(jrot, task, ioHandler, dimen, & + subroutine PTrestore_rot_kinetic_matrix_elements(jrot, task, ioHandler, dimen, & ncontr, maxcontr, icontr) use mpi_aux integer(ik),intent(in) :: jrot @@ -8872,7 +8872,7 @@ end subroutine divided_slice_close_mpi ! ! Here we restore the vibrational (J=0) matrix elements of the rotational kinetic part G_rot and G_cor ! - subroutine PTrestore_rot_kinetic_matrix_elements(jrot,task,ioHandler,dimen,ncontr,maxcontr,icontr) + subroutine PTrestore_rot_kinetic_matrix_elements_old(jrot,task,ioHandler,dimen,ncontr,maxcontr,icontr) ! integer(ik),intent(in) :: jrot character(len=cl),intent(in) :: task @@ -9493,7 +9493,7 @@ subroutine divided_slice_close_vib_rot(islice,name,chkptIO) ! end subroutine divided_slice_close_vib_rot - end subroutine PTrestore_rot_kinetic_matrix_elements + end subroutine PTrestore_rot_kinetic_matrix_elements_old ! ! ! From e7ab0fe019510ec91c27642abfad0a22696770d8 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Mon, 8 Nov 2021 12:07:20 +0000 Subject: [PATCH 41/66] Remove checks for MPIIO surrounding PTrestore --- perturbation.f90 | 79 ++++++++---------------------------------------- 1 file changed, 12 insertions(+), 67 deletions(-) diff --git a/perturbation.f90 b/perturbation.f90 index b1c038f..b406ff0 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -7661,12 +7661,7 @@ subroutine PThamiltonian_contract(jrot) call TimerStart('Calculating the Hamiltonian matrix') ! task = 'top' - if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,& - ncontr,maxcontr) - else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) - endif + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) ! ! We have two calculation options: fast and cheap and slow but expensive. ! @@ -7683,20 +7678,10 @@ subroutine PThamiltonian_contract(jrot) call TimerStart('Restoring KE matrix') ! task = 'rot' - if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,& - ncontr,maxcontr) - else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) - endif + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) ! task = 'cor' - if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,& - ncontr,maxcontr) - else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) - endif + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) ! call TimerStop('Restoring KE matrix') ! @@ -7711,13 +7696,8 @@ subroutine PThamiltonian_contract(jrot) call TimerStart('Restoring KE matrix') ! task = 'vib' - if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,& - ncontr,maxcontr) - else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) - endif - + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) + call TimerStop('Restoring KE matrix') ! if (job%verbose>=5) write(out,"(/' ...done!')") @@ -7790,12 +7770,7 @@ subroutine PThamiltonian_contract(jrot) if (job%verbose>=4) write(out,"(/' Construct the Hamiltonian matrix...')") ! task = 'top-icontr' - if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,& - ncontr,maxcontr) - else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) - endif + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) ! if (job%verbose>=5) write(out,"(' N Arrays of ',f12.5,'Gb each will be allocated (N is the number of processors)')") & real(sym%Nrepresen,rk)*real(PT%max_deg_size,rk)*real(max_dim,rk)*real(rk,rk)/1024.0_rk**3 @@ -7815,32 +7790,17 @@ subroutine PThamiltonian_contract(jrot) if (FLrotation.and.jrot/=0) then ! task = 'rot-icontr' - if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,& - ncontr,maxcontr) - else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr,icontr) - endif + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr,icontr) ! task = 'cor-icontr' - if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,& - ncontr,maxcontr) - else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr,icontr) - endif + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr,icontr) ! endif ! if ( PTvibrational_me_calc ) then ! task = 'vib-icontr' - if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,& - ncontr,maxcontr) - else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr,icontr) - endif + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr,icontr) ! endif ! @@ -7919,12 +7879,7 @@ subroutine PThamiltonian_contract(jrot) ! task = 'rot' ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,& - ncontr,maxcontr) - else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) - endif + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) ! ! $omp parallel private(mat_t,alloc_p) allocate (mat_t(sym%Nrepresen,PT%max_deg_size,max_dim),stat=alloc_p) @@ -7979,12 +7934,7 @@ subroutine PThamiltonian_contract(jrot) ! task = 'cor' ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,& - ncontr,maxcontr) - else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) - endif + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) ! ! $omp parallel private(mat_t,alloc_p) allocate (mat_t(sym%Nrepresen,PT%max_deg_size,max_dim),stat=alloc_p) @@ -8045,12 +7995,7 @@ subroutine PThamiltonian_contract(jrot) ! task = 'vib' ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,& - ncontr,maxcontr) - else - call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) - endif + call PTrestore_rot_kinetic_matrix_elements(jrot,task,kinetmatHandler,dimen,ncontr,maxcontr) ! ! $omp parallel private(mat_t,alloc_p) allocate (mat_t(sym%Nrepresen,PT%max_deg_size,max_dim),stat=alloc_p) From a8457124d7b6288bb4c3615e0f891125ea616626 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Mon, 8 Nov 2021 12:27:32 +0000 Subject: [PATCH 42/66] tidy up perturbation --- perturbation.f90 | 16 +--------------- 1 file changed, 1 insertion(+), 15 deletions(-) diff --git a/perturbation.f90 b/perturbation.f90 index b406ff0..f3464d2 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -8435,10 +8435,6 @@ subroutine PThamiltonian_contract(jrot) end subroutine PThamiltonian_contract ! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!!!!!!!! MPIIO !!!!!!!!!!!!!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - subroutine PTrestore_rot_kinetic_matrix_elements(jrot, task, ioHandler, dimen, & ncontr, maxcontr, icontr) use mpi_aux @@ -8473,7 +8469,7 @@ subroutine PTrestore_rot_kinetic_matrix_elements(jrot, task, ioHandler, dimen, & select case (trim(task)) case('top') - job_id = '[MPI-IO] Vib. matrix elements of the rot. kinetic' + job_id = 'Vib. matrix elements of the rot. kinetic' !TODO - MPI-compatible IOStart !call IOStart(trim(job_id),fileh) @@ -8602,16 +8598,10 @@ subroutine PTrestore_rot_kinetic_matrix_elements(jrot, task, ioHandler, dimen, & ! allocate(grot(3,3),stat=ierr) ! - islice = 0 - ! do k1 = 1,3 do k2 = 1,3 - ! - islice = islice + 1 - ! call co_create_distr_array(grot(k1,k2)%me, ncontr) call ioHandler%read(grot(k1,k2)%me, ncontr) - ! enddo enddo ! @@ -8622,7 +8612,6 @@ subroutine PTrestore_rot_kinetic_matrix_elements(jrot, task, ioHandler, dimen, & islice = 0 ! do k1 = 1,3 - ! do k2 = 1,3 ! islice = islice + 1 @@ -8643,9 +8632,6 @@ subroutine PTrestore_rot_kinetic_matrix_elements(jrot, task, ioHandler, dimen, & ! if (mpi_rank .eq. 0 .and. job%verbose>=4) write(out,"(' Read and process Coriolis part...')") ! - !allocate(mat_(maxcontr,maxcontr),stat=ierr) - !call ArrayStart('PThamiltonian_contract: mat_',ierr,1,kind(mat_),rootsize2_) - ! if (.not.job%IOmatelem_split) then ! call ioHandler%read(readbuf(1:5)) From 66502790ef7ee9b46f5b515ed865c507b75f8164 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Mon, 8 Nov 2021 12:30:47 +0000 Subject: [PATCH 43/66] Fix possibly disjoint file pointers in mpi writer --- io_handler_mpi.f90 | 13 +++++++++---- 1 file changed, 9 insertions(+), 4 deletions(-) diff --git a/io_handler_mpi.f90 b/io_handler_mpi.f90 index 29403dd..3eb0e70 100644 --- a/io_handler_mpi.f90 +++ b/io_handler_mpi.f90 @@ -411,17 +411,22 @@ subroutine read2DArrayDistColumnMPI(this, object, dimen) class(*), intent(out) :: object(:,:) integer, intent(in) :: dimen ! Dimension of entire distributed array - integer :: ierr + type(MPI_Datatype) :: mpiType_ + integer :: byteSize, arrSizeBytes, globalSize, ierr integer(kind = MPI_OFFSET_KIND) :: offset, disp + call getMPIVarInfo(object(1,1), byteSize, mpiType_) + arrSizeBytes = dimen*dimen*byteSize + ! Get individual pointer offset call MPI_File_get_position(this%fileh, offset, ierr) + call MPI_File_get_byte_offset(this%fileh, offset, disp, ierr) ! Set shared pointer to individual pointer + bookend - call MPI_File_seek_shared(this%fileh, offset+this%bookendBytes, MPI_SEEK_SET, ierr) + call MPI_File_seek_shared(this%fileh, disp+this%bookendBytes, MPI_SEEK_SET, ierr) ! Read array in parallel MPI_WRAPPER(MPI_File_read_ordered,this%fileh,object,1,mpitype_column,MPI_STATUS_IGNORE,ierr) - ! Skip over last bookend - call MPI_File_seek_shared(this%fileh, int(this%bookendBytes,MPI_OFFSET_KIND), MPI_SEEK_CUR, ierr) + ! Set shared pointer to point to byte after last bookend + call MPI_File_seek_shared(this%fileh, disp+this%bookendBytes+arrSizeBytes+this%bookendBytes, MPI_SEEK_SET) ! Set individual pointer to match shared call MPI_File_get_position_shared(this%fileh, offset, ierr) From c0523adb79cbc9105dfacfd38e8d26b3f42a2b5d Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Mon, 8 Nov 2021 12:38:44 +0000 Subject: [PATCH 44/66] Remove uneccessary MPI_Datatype --- io_handler_base.f90 | 1 - 1 file changed, 1 deletion(-) diff --git a/io_handler_base.f90 b/io_handler_base.f90 index 28bbd53..ef78fca 100644 --- a/io_handler_base.f90 +++ b/io_handler_base.f90 @@ -87,7 +87,6 @@ subroutine read2DArrayDistBlacs(this, object, descr, block_type) end subroutine subroutine read2DArrayDistColumn(this, object, dimen) import ioHandlerBase - import MPI_Datatype class(ioHandlerBase) :: this class(*), intent(out) :: object(:,:) integer, intent(in) :: dimen ! Dimension of entire distributed array From dd65520bc54e10fac21f32e05bb8f33eec92f175 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Mon, 8 Nov 2021 13:57:24 +0000 Subject: [PATCH 45/66] Fix incorrect reading of g_rot --- tran.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tran.f90 b/tran.f90 index adccbf5..175326c 100644 --- a/tran.f90 +++ b/tran.f90 @@ -2441,8 +2441,8 @@ subroutine restore_rot_kinetic_matrix_elements(jrot,treat_vibration,kinetic_part ! if (trim(kinetic_part)=='rot') then ! - call fileHandler%read(buf18(1:4)) - if (buf18(1:4)/='g_ro') then + call fileHandler%read(buf18(1:5)) + if (buf18(1:5)/='g_rot') then write (out,"(' Vib. kinetic checkpoint file ',a,': g_rot is missing ',a)") trim(job%kinetmat_file),buf18(1:5) ! if (buf18(1:4)=='hvib'.or.buf18(1:3)=='End') & From cc91f2d8bbdc5fb38ffe47860d9dffc6fad44845 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Mon, 8 Nov 2021 13:57:40 +0000 Subject: [PATCH 46/66] Remove pointless bookend check --- io_handler_mpi.f90 | 6 +----- 1 file changed, 1 insertion(+), 5 deletions(-) diff --git a/io_handler_mpi.f90 b/io_handler_mpi.f90 index 3eb0e70..4359426 100644 --- a/io_handler_mpi.f90 +++ b/io_handler_mpi.f90 @@ -143,11 +143,7 @@ subroutine seek(this, offset) integer, intent(in) :: offset integer(kind=MPI_OFFSET_KIND) :: total_offset - if (trim(this%accessVal) == "sequential" .and. offset .ne. 0) then - ! Add two bookend offsets - total_offset = offset + 2*4 - endif - call MPI_File_seek(this%fileh, total_offset, MPI_SEEK_CUR) + call MPI_File_seek(this%fileh, offset + 2*this%bookendBytes, MPI_SEEK_CUR) end subroutine subroutine getMPIVarInfo(object, byteSize, mpiType) From bd09c5d1617c81c5c9348c293c5efbf6b20c0b98 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Mon, 8 Nov 2021 13:58:12 +0000 Subject: [PATCH 47/66] Fix names of tests --- test/unit/test_mpi_io.pf | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/test/unit/test_mpi_io.pf b/test/unit/test_mpi_io.pf index 54affe6..317d343 100644 --- a/test/unit/test_mpi_io.pf +++ b/test/unit/test_mpi_io.pf @@ -374,7 +374,7 @@ module test_mpi_io end subroutine @test - subroutine testMPIReadBlacsDistArray(this) + subroutine testMPIReadColumnDistArray(this) class(TestMPI), intent(inout) :: this type(ioHandlerMPI) :: ioHandler @@ -476,7 +476,7 @@ module test_mpi_io end subroutine @test - subroutine testMPIReadColumnDistArray(this) + subroutine testMPIReadBlacsDistArray(this) class(TestMPI), intent(inout) :: this type(ioHandlerMPI) :: ioHandler From 769bdfa63dba830b881ae0ddeaee0a6046255112 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Mon, 8 Nov 2021 17:09:47 +0000 Subject: [PATCH 48/66] Fix non-mpi parts of PTrestore --- perturbation.f90 | 595 ++++++++--------------------------------------- 1 file changed, 94 insertions(+), 501 deletions(-) diff --git a/perturbation.f90 b/perturbation.f90 index f3464d2..91c9868 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -7871,7 +7871,6 @@ subroutine PThamiltonian_contract(jrot) if (FLrotation.and.jrot/=0.and..not.job%vib_rot_contr) then ! if (job%verbose>=4) write(out,"(' Rotational part...')") - ! ! AT - Initialise parallel distribution (if not done yet) ! TODO - find correct spot to place this w/ appropriate guard clauses ! NOTE don't know `ncontr` until after calling PTrestore.. with `task=='top'` @@ -8454,10 +8453,15 @@ subroutine PTrestore_rot_kinetic_matrix_elements(jrot, task, ioHandler, dimen, & integer :: file_offset integer :: ierr integer(hik) :: nprocs,tid,icontr1,icontr2 + integer :: OMP_GET_NUM_THREADS,omp_get_thread_num integer(ik),allocatable :: imat_t(:,:) real(rk),allocatable :: mat_t(:,:),mat_(:,:) real(rk) :: f_t + integer(ik) :: chkptIO, chkptIO_ + integer(ik) :: maxcontr0 + integer(hik) :: rootsize2_ + integer :: k1,k2,islice if ( trim(job%IOkinet_action)/='VIB_READ'.and.trim(job%IOkinet_action)/='READ'.and..not.job%contrci_me_fast) return @@ -8723,414 +8727,13 @@ subroutine PTrestore_rot_kinetic_matrix_elements(jrot, task, ioHandler, dimen, & deallocate(ioHandler) ! if (mpi_rank .eq. 0 .and. job%verbose>=4) write(out,"(' ...done!')") - ! - case('top-icontr') - write(*,*) "CASE TOP-ICONTR" - ! TODO MPI - case('rot-icontr') ! rotational part for the vib-rot contraction scheme - write(*,*) "CASE ROT-ICONTR" - ! TODO MPI - case('cor-icontr') ! corriolis part for the vib-rot contraction scheme - write(*,*) "CASE COR-ICONTR" - ! TODO MPI - case('vib-icontr') ! vibrational part for the vib-rot contraction scheme - write(*,*) "CASE VIB-ICONTR" - ! TODO MPI - end select - end subroutine - - subroutine divided_slice_open_mpi(islice,sliceHandler,chkpt_type,suffix) - use mpi_aux - implicit none - integer(ik),intent(in) :: islice - class(ioHandlerBase), allocatable, intent(out) :: sliceHandler - character(len=*),intent(in) :: chkpt_type,suffix - - integer(ik) :: ilen - character(len=cl) :: readbuf,filename,jchar - type(ErrorType) :: err - integer :: ierr - - if (.not.job%IOmatelem_split) return - ! - !write(job_is,"('single swap_matrix')") - ! - !call IOStart(trim(job_is),chkptIO) - ! - write(jchar, '(i4)') islice - ! - filename = trim(suffix)//trim(adjustl(jchar))//'.chk' - ! - call openFile(sliceHandler, filename, err, action='read', & - position='rewind', status='old', form='unformatted') - HANDLE_ERROR(err) - ! - ilen = LEN_TRIM(chkpt_type) - ! - call sliceHandler%read(readbuf(1:ilen)) - if ( trim(readbuf(1:ilen))/=trim(chkpt_type) ) then - if (mpi_rank .eq. 0) write (out,"('divided_slice_open, kinetic checkpoint slice ',a20,': header is missing or wrong',a)") filename,readbuf(1:ilen) - stop 'PTrestore_rot_kinetic_matrix_elements- in slice - header missing or wrong' - end if - end subroutine divided_slice_open_mpi - - subroutine divided_slice_close_mpi(islice,sliceHandler,chkpt_type) - use mpi_aux - integer(ik),intent(in) :: islice - class(ioHandlerBase), allocatable, intent(inout) :: sliceHandler - character(len=*),intent(in) :: chkpt_type - - integer(ik) :: ilen - character(len=cl) :: readbuf - type(ErrorType) :: err - integer :: ierr - - if (.not.job%IOmatelem_split) return - ! - ilen = LEN_TRIM(chkpt_type) - ! - call sliceHandler%read(readbuf(1:ilen)) - if ( trim(readbuf(1:ilen))/=trim(chkpt_type) ) then - if(mpi_rank .eq. 0) write (out,"('divided_slice_close, kinetic checkpoint slice: footer is missing or wrong',a)") readbuf(1:ilen) - stop 'divided_slice_close - in slice - footer missing or wrong' - end if - deallocate(sliceHandler) - end subroutine divided_slice_close_mpi - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !!!!!!!! POSIX IO !!!!!!!!!!!! - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - ! - ! Here we restore the vibrational (J=0) matrix elements of the rotational kinetic part G_rot and G_cor - ! - subroutine PTrestore_rot_kinetic_matrix_elements_old(jrot,task,ioHandler,dimen,ncontr,maxcontr,icontr) - ! - integer(ik),intent(in) :: jrot - character(len=cl),intent(in) :: task - class(ioHandlerBase), allocatable, intent(inout) :: ioHandler - integer(ik),intent(in) :: dimen - integer(ik),intent(inout),optional :: ncontr - integer(ik),intent(inout),optional :: maxcontr - integer(ik),intent(in),optional :: icontr - ! - integer(ik) :: chkptIO - integer(ik) :: alloc - character(len=cl) :: job_is,filename - character(len=18) :: buf18 - integer(ik) :: k1,k2,j,ib0,islice,chkptIO_,ideg,icontr0,istart,iend,maxcontr0 - integer(ik),allocatable :: imat_t(:,:) - integer(hik) :: rootsize,rootsize_,rootsize2,rootsize2_,nprocs,tid,icontr1,icontr2 - integer :: OMP_GET_NUM_THREADS,omp_get_thread_num - real(rk),allocatable :: mat_t(:,:),mat_(:,:) - real(rk) :: f_t - ! - ! Return if there is nothing to read - ! - if ( trim(job%IOkinet_action)/='VIB_READ'.and.trim(job%IOkinet_action)/='READ'.and..not.job%contrci_me_fast) return - ! - if ( trim(job%IOswap_matelem)/='NONE') return - ! - rootsize = int(ncontr*(ncontr+1)/2,hik) - rootsize_ = int(maxcontr*(maxcontr+1)/2,hik) - ! - rootsize2 = int(ncontr*ncontr,hik) - rootsize2_ = int(maxcontr*maxcontr,hik) - ! - !dimen = max(min(int(PT%Maxcontracts*job%compress),PT%Maxcontracts),1) - if (job%verbose>=6.and.present(icontr)) write(out,"('icontr = ',i9)") icontr - ! - select case (trim(task)) - ! - case('top') - ! - job_is ='Vib. matrix elements of the rot. kinetic' - call IOStart(trim(job_is),chkptIO) - ! - !open(chkptIO,form='unformatted',action='read',position='rewind',status='old',file=job%kinetmat_file,recordtype='variable') - ! - open(chkptIO,form='unformatted',action='read',position='rewind',status='old',file=job%kinetmat_file) - ! - read(chkptIO) buf18 - if (buf18/='Start Kinetic part') then - write (out,"(' Vib. kinetic checkpoint file ',a,' has bogus header: ',a)") job%kinetmat_file,buf18 - stop 'PTrestore_rot_kinetic_matrix_elements - bogus file format' - end if - ! - read(chkptIO) ncontr - ! - if (jrot==0.and.PT%Maxcontracts/=ncontr.and.(.not.trove%triatom_sing_resolve ) ) then - write (out,"(' Vib. kinetic checkpoint file ',a)") job%kinetmat_file - write (out,"(' Actual and stored basis sizes at J=0 do not agree ',2i0)") PT%Maxcontracts,ncontr - stop 'PTrestore_rot_kinetic_matrix_elements - in file - illegal nroots ' - end if - ! - rootsize = int(ncontr*(ncontr+1)/2,hik) - rootsize2 = int(ncontr*ncontr,hik) - ! - if (job%verbose>=6) write(out,"(/'Restore_rot_kin...: Number of elements: ',i8)") PT%Maxcontracts - ! - ! Read the indexes of the J=0 contracted basis set. - ! - if (.not.FLrotation.or.jrot==0) then - ! - allocate (imat_t(0:PT%Nclasses,ncontr),stat=alloc) - call ArrayStart('mat_t',alloc,size(imat_t),kind(imat_t)) - ! - read(chkptIO) 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(chkptIO) imat_t(0:PT%Nclasses,1:ncontr) - ! - read(chkptIO) 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(chkptIO) imat_t(0:PT%Nclasses,1:ncontr) - ! - deallocate(imat_t) - ! - else - ! - allocate (PT%icontr_cnu(0:PT%Nclasses,ncontr),PT%icontr_ideg(0:PT%Nclasses,ncontr),stat=alloc) - call ArrayStart('PT%contractive_space',alloc,size(PT%icontr_cnu),kind(PT%icontr_cnu)) - call ArrayStart('PT%contractive_space',alloc,size(PT%icontr_ideg),kind(PT%icontr_ideg)) - ! - deallocate(PT%icontr2icase) - call Arraystop('PT%contractive_space') - ! - allocate (PT%icontr2icase(ncontr,2),stat=alloc) - call ArrayStart('PT%contractive_space',alloc,size(PT%icontr2icase),kind(PT%icontr2icase)) - ! - read(chkptIO) 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(chkptIO) PT%icontr_cnu(0:PT%Nclasses,1:ncontr) - ! - read(chkptIO) 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(chkptIO) PT%icontr_ideg(0:PT%Nclasses,1:ncontr) - ! - endif - ! - if (job%vib_rot_contr.and.PTvibrational_me_calc) then - ! - read(chkptIO) buf18(1:7) - if (buf18(1:7)/='vib-rot') then - write (out,"(' Vib. kinetic checkpoint file ',a,': label vib-rot is missing ',a)") job%kinetmat_file,buf18(1:7) - stop 'PTrestore_rot_kinetic_matrix_elements - in file - vib-rot missing' - end if - ! - close(chkptIO) - ! - write(job_is,"('single swap_matrix')") - ! - call IOStart(trim(job_is),chkptIO) - ! - filename = trim(job%matelem_suffix)//"0"//'.chk' - ! - open(chkptIO,form='unformatted',action='read',status='old',file=filename) - ! - endif - ! - ! reconstruct the correlation between the vib. indices for J=0 and current J - ! - call Find_groundstate_icontr(maxcontr) - ! - if (job%verbose>=4) write(out,"(' ...done!')") - ! - if (job%verbose>=4.and.maxcontr/=ncontr) then - write (out,"(' The contracted basis set is reduced: ',i8,' -> ',i8)") ncontr,maxcontr - end if - ! - if (maxcontr>ncontr) then - write (out,"(' Actual and stored basis sizes at J=0 do not agree (maxcontr,ncontr) ',2i8)") maxcontr,ncontr - stop 'PTrestore_rot_kinetic_matrix_elements - in file - illegal ncontr ' - end if - ! - case('rot') - ! - if (job%verbose>=4) write(out,"(' Read and process rotational part...')") - ! - ! Read the rotational part only - ! - allocate(mat_(maxcontr,maxcontr),stat=alloc) - call ArrayStart('PThamiltonian_contract: mat_',alloc,1,kind(mat_),rootsize2_) - ! - if (.not.job%IOmatelem_split) then - ! - read(chkptIO) buf18(1:5) - if (buf18(1:5)/='g_rot') then - write (out,"(' Vib. kinetic checkpoint file ',a,': g_rot is missing ',a)") job%kinetmat_file,buf18(1:5) - stop 'PTrestore_rot_kinetic_matrix_elements - in file - g_rot missing' - end if - ! - endif - ! - allocate(grot(3,3),stat=alloc) - ! - islice = 0 - chkptIO_ = chkptIO - ! - do k1 = 1,3 - ! - do k2 = 1,3 - ! - islice = islice + 1 - ! - call divided_slice_open(islice,chkptIO_,'g_rot',job%matelem_suffix) - ! - allocate(grot(k1,k2)%me(maxcontr,maxcontr),stat=alloc) - call ArrayStart('grot-matrix',alloc,1,kind(f_t),rootsize2_) - ! - read(chkptIO_) mat_ - ! - grot(k1,k2)%me(1:ncontr,1:ncontr) = mat_(1:ncontr,1:ncontr) - ! - call divided_slice_close(islice,chkptIO_,'g_rot') - ! - enddo - enddo - ! - deallocate(mat_) - call ArrayStop('PThamiltonian_contract: mat_') - ! - if (job%verbose>=4) write(out,"(' ...done!')") - ! - case('cor') - ! - if (job%verbose>=4) write(out,"(' Read and process Coriolis part...')") - ! - allocate(mat_(maxcontr,maxcontr),stat=alloc) - call ArrayStart('PThamiltonian_contract: mat_',alloc,1,kind(mat_),rootsize2_) - ! - if (.not.job%IOmatelem_split) then - ! - read(chkptIO) buf18(1:5) - if (buf18(1:5)/='g_cor') then - write (out,"(' Vib. kinetic checkpoint file ',a,': g_cor is missing ',a)") job%kinetmat_file,buf18(1:5) - stop 'PTrestore_rot_kinetic_matrix_elements - in file - g_cor missing' - end if - ! - endif - ! - allocate(gcor(3),stat=alloc) - ! - islice = 9 - chkptIO_ = chkptIO - ! - do k1 = 1,3 - ! - islice = islice + 1 - ! - allocate(gcor(k1)%me(maxcontr,maxcontr),stat=alloc) - call ArrayStart('gcor-matrix',alloc,1,kind(f_t),rootsize2_) - ! - call divided_slice_open(islice,chkptIO_,'g_cor',job%matelem_suffix) - ! - read(chkptIO_) mat_ - ! - gcor(k1)%me(1:ncontr,1:ncontr) = mat_(1:ncontr,1:ncontr) - ! - call divided_slice_close(islice,chkptIO_,'g_cor') - ! - enddo - ! - deallocate(mat_) - call ArrayStop('PThamiltonian_contract: mat_') - ! - if (job%verbose>=4) write(out,"(' ...done!')") - ! - case('vib') - ! - if (job%verbose>=4) write(out,"(' Read and process vibrational part...')") - ! - if (.not.job%IOmatelem_split.and.( (.not.FLrotation.or.jrot==0).and.trim(job%IOkinet_action)/='VIB_READ' ) ) then - ! - allocate(mat_t(maxcontr,maxcontr),stat=alloc) - call ArrayStart('PThamiltonian_contract: mat_t',alloc,1,kind(mat_t),rootsize2_) - ! - read(chkptIO) buf18(1:5) - if (buf18(1:5)/='g_rot') then - write (out,"(' Vib. kinetic checkpoint file ',a,': g_rot is missing ',a)") job%kinetmat_file,buf18(1:5) - stop 'PTrestore_rot_kinetic_matrix_elements - in file - g_rot missing' - end if - ! - do k1 = 1,3 - do k2 = 1,3 - ! - read(chkptIO) mat_t - ! - enddo - enddo - ! - read(chkptIO) buf18(1:5) - if (buf18(1:5)/='g_cor') then - write (out,"(' Vib. kinetic checkpoint file ',a,': g_cor is missing ',a)") job%kinetmat_file,buf18(1:5) - stop 'PTrestore_rot_kinetic_matrix_elements - in file - g_cor missing' - end if - ! - !do k1 = 1,PT%Nmodes - do k2 = 1,3 - ! - read(chkptIO) mat_t - ! - enddo - !enddo - ! - deallocate(mat_t) - call ArrayStop('mat_t') - ! - endif - ! - if (job%verbose>=6) write(out,"(' rootsize_,rootsize = ',2i0)") rootsize_,rootsize - ! - read(chkptIO) buf18(1:4) - if (buf18(1:4)/='hvib') then - write (out,"(' Vib. kinetic checkpoint file ',a,': hvib is missing ',a)") job%kinetmat_file,buf18(1:4) - if (buf18(1:4)=='g_ro') then - write (out,"(' Most likely non-divided chk-points used with MATELEM READ SPLIT')") - write (out,"(' Re-do MATELEM SAVE SPLIT or use MATELEM SPLIT READ')") - endif - stop 'PTrestore_rot_kinetic_matrix_elements - in file - hvib or End missing' - end if - ! - allocate(mat_(maxcontr,maxcontr),stat=alloc) - call ArrayStart('PThamiltonian_contract: mat_',alloc,1,kind(mat_),rootsize2_) - ! - allocate(hvib%me(maxcontr,maxcontr),stat=alloc) - call ArrayStart('hvib-matrix',alloc,1,kind(f_t),rootsize2_) - ! - read(chkptIO) mat_ - ! - hvib%me(1:ncontr,1:ncontr) = mat_(1:ncontr,1:ncontr) - ! - deallocate(mat_) - call ArrayStop('PThamiltonian_contract: mat_') - ! - read(chkptIO) buf18(1:16) - if (buf18(1:16)/='End Kinetic part') then - write (out,"(' Vib. kinetic checkpoint file ',a,' has bogus footer: ',a)") job%kinetmat_file,buf18(1:16) - stop 'PTrestore_rot_kinetic_matrix_elements - bogus file format' - end if - ! - close(chkptIO,status='keep') - ! - if (job%verbose>=4) write(out,"(' ...done!')") - ! case('top-icontr') - ! + if (blacs_size .gt. 1) then + if (mpi_rank .eq. 0) write (out,*) "task=top-icontr is not implemented for MPI." + stop 'PTrestore_rot_kinetic_matrix_elements - unimplemented MPI' + endif + nprocs = 1 tid = 0 !$omp parallel private(tid) @@ -9142,14 +8745,14 @@ subroutine PTrestore_rot_kinetic_matrix_elements_old(jrot,task,ioHandler,dimen,n ! if (FLrotation.and.jrot/=0) then ! - allocate(grot(3,3),stat=alloc) + allocate(grot(3,3),stat=ierr) ! rootsize2_ = int(maxcontr,hik)*int(PT%max_deg_size,hik)*9_hik*int(nprocs,hik) - call ArrayStart('PThamiltonian_contract: grot',alloc,1,rk,rootsize2_) + call ArrayStart('PThamiltonian_contract: grot',ierr,1,rk,rootsize2_) ! - allocate(gcor(3),stat=alloc) + allocate(gcor(3),stat=ierr) rootsize2_ = int(maxcontr,hik)*int(PT%max_deg_size,hik)*int(PT%Nmodes,hik)*3_hik*int(nprocs,hik) - call ArrayStart('PThamiltonian_contract: grot',alloc,1,rk,rootsize2_) + call ArrayStart('PThamiltonian_contract: grot',ierr,1,rk,rootsize2_) ! if (job%vib_rot_contr) then ! @@ -9160,11 +8763,8 @@ subroutine PTrestore_rot_kinetic_matrix_elements_old(jrot,task,ioHandler,dimen,n endif ! endif - ! + case('rot-icontr') ! rotational part for the vib-rot contraction scheme - ! - ! Read the rotational part only - ! if (.not.job%IOmatelem_split ) then ! write (out,"('PTrestore_rot_kinetic_matrix_elements: vib-rot can be used with MATELEM SAVE SPLIT only ')") @@ -9188,21 +8788,18 @@ subroutine PTrestore_rot_kinetic_matrix_elements_old(jrot,task,ioHandler,dimen,n ! if (associated(grot(k1,k2)%me)) deallocate(grot(k1,k2)%me) ! - allocate(grot(k1,k2)%me(maxcontr,icontr1:icontr2),stat=alloc) + allocate(grot(k1,k2)%me(maxcontr,icontr1:icontr2),stat=ierr) ! - write(job_is,"('single swap_matrix #',i8)") islice - call IOStart(trim(job_is),chkptIO_) + write(job_id,"('single swap_matrix #',i8)") islice + call IOStart(trim(job_id),chkptIO_) ! read(chkptIO_) grot(k1,k2)%me ! enddo enddo - ! + case('cor-icontr') ! corriolis part for the vib-rot contraction scheme - ! - ! Read the Corriolis part only - ! - ! + ! Read the Coriolis part only if (.not.job%IOmatelem_split ) then ! write (out,"('PTrestore_rot_kinetic_matrix_elements: vib-rot can be used with MATELEM SAVE SPLIT only ')") @@ -9230,17 +8827,16 @@ subroutine PTrestore_rot_kinetic_matrix_elements_old(jrot,task,ioHandler,dimen,n ! if (associated(gcor(k1)%me)) deallocate(gcor(k1)%me) ! - allocate(gcor(k1)%me(maxcontr,icontr1:icontr2),stat=alloc) + allocate(gcor(k1)%me(maxcontr,icontr1:icontr2),stat=ierr) ! - write(job_is,"('single swap_matrix #',i8)") islice - call IOStart(trim(job_is),chkptIO_) + write(job_id,"('single swap_matrix #',i8)") islice + call IOStart(trim(job_id),chkptIO_) ! read(chkptIO_) gcor(k1)%me ! enddo - ! + case('vib-icontr') ! vibrational part for the vib-rot contraction scheme - ! ! !if (job%verbose>=4.and.irow==0) write(out,"(' Read and process vibrational part...')") ! @@ -9255,10 +8851,10 @@ subroutine PTrestore_rot_kinetic_matrix_elements_old(jrot,task,ioHandler,dimen,n ! if (icontr==1) then ! - read(chkptIO) buf18(1:4) - if (buf18(1:4)/='hvib') then - write (out,"(' Vib. kinetic checkpoint file ',a,': hvib is missing ',a)") job%kinetmat_file,buf18(1:4) - if (buf18(1:4)=='g_ro') write (out,"(' Most likely non-divided chk-points used with MATELEM READ DIVIDED')") + read(chkptIO) readbuf(1:4) + if (readbuf(1:4)/='hvib') then + write (out,"(' Vib. kinetic checkpoint file ',a,': hvib is missing ',a)") job%kinetmat_file,readbuf(1:4) + if (readbuf(1:4)=='g_ro') write (out,"(' Most likely non-divided chk-points used with MATELEM READ DIVIDED')") write (out,"(' Re-do MATELEM SAVE DIVIDE or use MATELEM READ!')") stop 'PTrestore_rot_kinetic_matrix_elements - in file - hvib or End missing' end if @@ -9279,8 +8875,8 @@ subroutine PTrestore_rot_kinetic_matrix_elements_old(jrot,task,ioHandler,dimen,n ! if (job%verbose>=6) write(out,"('allocate hvib for ',i9,' x ',i8,' -> ',i8)") maxcontr,icontr1,icontr2 ! - allocate(hvib%me(maxcontr,icontr1:icontr2),stat=alloc) - call ArrayStart('hvib-matrix',alloc,1,kind(f_t),rootsize2_) + allocate(hvib%me(maxcontr,icontr1:icontr2),stat=ierr) + call ArrayStart('hvib-matrix',ierr,1,kind(f_t),rootsize2_) ! read(chkptIO) hvib%me ! @@ -9288,9 +8884,9 @@ subroutine PTrestore_rot_kinetic_matrix_elements_old(jrot,task,ioHandler,dimen,n ! if (icontr==maxcontr0) then ! - read(chkptIO) buf18(1:4) - if (buf18(1:4)/='hvib') then - write (out,"(' Vib. kinetic checkpoint file ',a,' has bogus footer: ',a)") job%kinetmat_file,buf18(1:4) + read(chkptIO) readbuf(1:4) + if (readbuf(1:4)/='hvib') then + write (out,"(' Vib. kinetic checkpoint file ',a,' has bogus footer: ',a)") job%kinetmat_file,readbuf(1:4) stop 'PTrestore_rot_kinetic_matrix_elements - bogus file format' end if ! @@ -9301,68 +8897,9 @@ subroutine PTrestore_rot_kinetic_matrix_elements_old(jrot,task,ioHandler,dimen,n endif ! end select - ! - contains - ! - subroutine divided_slice_open(islice,chkptIO,name,suffix) - ! - implicit none - integer(ik),intent(in) :: islice - integer(ik),intent(inout) :: chkptIO - character(len=*),intent(in) :: name,suffix - character(len=4) :: jchar - character(len=cl) :: buf,filename,job_is - integer(ik) :: ilen - logical :: ifopened - ! - if (.not.job%IOmatelem_split) return - ! - write(job_is,"('single swap_matrix')") - ! - call IOStart(trim(job_is),chkptIO) - ! - write(jchar, '(i4)') islice - ! - filename = trim(suffix)//trim(adjustl(jchar))//'.chk' - ! - open(chkptIO,form='unformatted',action='read',position='rewind',status='old',file=filename) - ! - ilen = LEN_TRIM(name) - ! - read(chkptIO) buf(1:ilen) - if ( trim(buf(1:ilen))/=trim(name) ) then - write (out,"(' kinetic checkpoint slice ',a20,': header is missing or wrong',a)") filename,buf(1:ilen) - stop 'PTrestore_rot_kinetic_matrix_elements - in slice - header missing or wrong' - end if - ! - end subroutine divided_slice_open - ! - subroutine divided_slice_close(islice,chkptIO,name) - ! - integer(ik),intent(in) :: islice - integer(ik),intent(inout) :: chkptIO - character(len=*),intent(in) :: name - character(len=4) :: jchar - character(len=cl) :: buf,filename - integer(ik) :: ilen - logical :: ifopened - ! - if (.not.job%IOmatelem_split) return - ! - ilen = LEN_TRIM(name) - ! - read(chkptIO) buf(1:ilen) - if ( trim(buf(1:ilen))/=trim(name) ) then - write (out,"(' divided_slice_close, kinetic checkpoint slice ',a,': footer is missing or wrong',a)") & - filename,buf(1:ilen) - stop 'divided_slice_close - in slice - footer missing or wrong' - end if - ! - close(chkptIO) - ! - end subroutine divided_slice_close - ! + contains + subroutine divided_slice_open_vib_rot(islice,suffix) ! implicit none @@ -9424,9 +8961,65 @@ subroutine divided_slice_close_vib_rot(islice,name,chkptIO) ! end subroutine divided_slice_close_vib_rot - end subroutine PTrestore_rot_kinetic_matrix_elements_old - ! - ! + subroutine divided_slice_open_mpi(islice,sliceHandler,chkpt_type,suffix) + use mpi_aux + implicit none + integer(ik),intent(in) :: islice + class(ioHandlerBase), allocatable, intent(out) :: sliceHandler + character(len=*),intent(in) :: chkpt_type,suffix + + integer(ik) :: ilen + character(len=cl) :: readbuf,filename,jchar + type(ErrorType) :: err + integer :: ierr + + if (.not.job%IOmatelem_split) return + ! + !write(job_is,"('single swap_matrix')") + ! + !call IOStart(trim(job_is),chkptIO) + ! + write(jchar, '(i4)') islice + ! + filename = trim(suffix)//trim(adjustl(jchar))//'.chk' + ! + call openFile(sliceHandler, filename, err, action='read', & + position='rewind', status='old', form='unformatted') + HANDLE_ERROR(err) + ! + ilen = LEN_TRIM(chkpt_type) + ! + call sliceHandler%read(readbuf(1:ilen)) + if ( trim(readbuf(1:ilen))/=trim(chkpt_type) ) then + if (mpi_rank .eq. 0) write (out,"('divided_slice_open, kinetic checkpoint slice ',a20,': header is missing or wrong',a)") filename,readbuf(1:ilen) + stop 'PTrestore_rot_kinetic_matrix_elements- in slice - header missing or wrong' + end if + end subroutine divided_slice_open_mpi + + subroutine divided_slice_close_mpi(islice,sliceHandler,chkpt_type) + use mpi_aux + integer(ik),intent(in) :: islice + class(ioHandlerBase), allocatable, intent(inout) :: sliceHandler + character(len=*),intent(in) :: chkpt_type + + integer(ik) :: ilen + character(len=cl) :: readbuf + type(ErrorType) :: err + integer :: ierr + + if (.not.job%IOmatelem_split) return + ! + ilen = LEN_TRIM(chkpt_type) + ! + call sliceHandler%read(readbuf(1:ilen)) + if ( trim(readbuf(1:ilen))/=trim(chkpt_type) ) then + if(mpi_rank .eq. 0) write (out,"('divided_slice_close, kinetic checkpoint slice: footer is missing or wrong',a)") readbuf(1:ilen) + stop 'divided_slice_close - in slice - footer missing or wrong' + end if + deallocate(sliceHandler) + end subroutine divided_slice_close_mpi + + end subroutine ! ! We construct the Hamiltonian matrix in symm. adapted representaion ! for the K-factorized rotational basis From 8d18f42c8436ee5faa569b316cef515fcffd7e60 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Tue, 9 Nov 2021 09:16:42 +0000 Subject: [PATCH 49/66] Only try running MPI unit tests if USE_MPI set in makefile --- makefile | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/makefile b/makefile index 137f835..5753020 100644 --- a/makefile +++ b/makefile @@ -165,7 +165,11 @@ tarball: checkin: ci -l Makefile *.f90 +ifeq ($(USE_MPI,1)) test: regression-tests unit-tests-nompi unit-tests-mpi +else +test: regression-tests unit-tests-nompi +endif regression-tests: $(TARGET) echo "Running regression tests" From 82fef8003e422391a01049294360118228a175a2 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Tue, 9 Nov 2021 09:19:14 +0000 Subject: [PATCH 50/66] Fix error in makefile --- makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/makefile b/makefile index 5753020..1656ec1 100644 --- a/makefile +++ b/makefile @@ -165,7 +165,7 @@ tarball: checkin: ci -l Makefile *.f90 -ifeq ($(USE_MPI,1)) +ifeq ($(USE_MPI),1) test: regression-tests unit-tests-nompi unit-tests-mpi else test: regression-tests unit-tests-nompi From a1ec15683fbb2c59a602e3563767f3d24580f514 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Tue, 9 Nov 2021 09:28:03 +0000 Subject: [PATCH 51/66] Remove non-portable mpirun argument --- makefile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/makefile b/makefile index 1656ec1..73a28d7 100644 --- a/makefile +++ b/makefile @@ -184,7 +184,7 @@ ifeq ($(USE_MPI),1) unit-tests-mpi: io_handler_mpi.o $(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 + mpirun -n 4 test/unit/test_mpi_io else unit-tests-mpi: $(error set USE_MPI=1 to compile & test with MPI) From 42f09e86831be0d19a71aeae5467a77ccd357216 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Tue, 9 Nov 2021 10:41:57 +0000 Subject: [PATCH 52/66] Remove another non-portable mpirun flag --- test/regression/scripts/H2CO/run_benchmark.sh | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/regression/scripts/H2CO/run_benchmark.sh b/test/regression/scripts/H2CO/run_benchmark.sh index 5acc493..31e0704 100755 --- a/test/regression/scripts/H2CO/run_benchmark.sh +++ b/test/regression/scripts/H2CO/run_benchmark.sh @@ -14,7 +14,7 @@ ulimit -d unlimited if [[ ${USE_MPI} == 1 ]]; then echo "MPI enabled" - LAUNCH="time mpirun -np $nproc --mca opal_warn_on_missing_libcuda 0" + LAUNCH="time mpirun -np $nproc" ./set_io_format.sh enable export OMP_NUM_THREADS=1 else From 6937f0f96ab89cf12351d76d61694dee59d45308 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Tue, 9 Nov 2021 16:41:20 +0000 Subject: [PATCH 53/66] Move test of intensity files to run after tests of other files so we can be sure earlier files are fine --- test/regression/scripts/H2CO/compare_results.sh | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/test/regression/scripts/H2CO/compare_results.sh b/test/regression/scripts/H2CO/compare_results.sh index 1c1ffdc..e4cd39a 100755 --- a/test/regression/scripts/H2CO/compare_results.sh +++ b/test/regression/scripts/H2CO/compare_results.sh @@ -11,12 +11,13 @@ quantum_files="eigen_descr0_1.chk eigen_descr0_2.chk eigen_descr0_3.chk eigen_de python compare_results.py --kind quantum --folder1 "$folder1" --folder2 "$folder2" $quantum_files -if [[ ${USE_MPI} -ne 1 ]]; then - python compare_results.py --kind intensity --precision 5e-6 --folder1 "$folder1" --folder2 "$folder2" file_intensity.out -fi - python compare_results.py --kind column --column 3 --precision 5e-3 --folder1 "$folder1" --folder2 "$folder2" external.chk python compare_results.py --kind column --column 2 --precision 1e-8 --folder1 "$folder1" --folder2 "$folder2" potential.chk python compare_results.py --kind column --column 4 --precision 1e-8 --folder1 "$folder1" --folder2 "$folder2" kinetic.chk + +if [[ ${USE_MPI} -ne 1 ]]; then + python compare_results.py --kind intensity --precision 5e-6 --folder1 "$folder1" --folder2 "$folder2" file_intensity.out +fi + From 71eeda3f3a183abb3c9cce210e30421db02db6ad Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Wed, 10 Nov 2021 10:50:52 +0000 Subject: [PATCH 54/66] Add test for seeking while reading a file using MPI --- test/unit/test_mpi_io.pf | 75 +++++++++++++++++++++++++++++++++++++--- 1 file changed, 71 insertions(+), 4 deletions(-) diff --git a/test/unit/test_mpi_io.pf b/test/unit/test_mpi_io.pf index 317d343..66b1b87 100644 --- a/test/unit/test_mpi_io.pf +++ b/test/unit/test_mpi_io.pf @@ -21,7 +21,7 @@ module test_mpi_io integer,external :: INDXL2G logical :: is_mpi_initialised = .false. - integer, parameter :: totalTestCount = 6 ! CHANGE ME TO NUMBER OF TESTS + integer, parameter :: totalTestCount = 7 ! CHANGE ME TO NUMBER OF TESTS integer :: currentTestCount = 0 contains @@ -217,8 +217,8 @@ module test_mpi_io character(len=*), parameter :: access = "sequential" real(rk) :: grot_full(dimen, dimen) - real(rk), allocatable :: grot_t(:,:) - real(rk),allocatable :: recvbuf(:,:,:) + real(rk), pointer :: grot_t(:,:) + real(rk), allocatable :: recvbuf(:,:,:) integer :: true_integer = 5, in_integer @@ -383,7 +383,7 @@ module test_mpi_io integer :: startdim_, enddim_, blocksize_ real(rk) :: true_array(dimen,dimen) - real(rk), allocatable :: in_array(:,:) + real(rk), pointer :: in_array(:,:) integer :: true_integer = 5, in_integer @@ -579,4 +579,71 @@ module test_mpi_io endif end subroutine + + @test + subroutine testSeekWhileReading(this) + class(TestMPI), intent(inout) :: this + type(ioHandlerMPI) :: ioHandler + + real :: true_real = 4.0, in_real + integer :: dummy_arr(1:5) + integer :: true_integer = 5, 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 + + integer :: ierr, rank, allocinfo = 0 + type(ErrorType) :: err + + ! Set up MPI + call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr) + if(ierr.ne.0) print *, "Error: could not get rank" + + ! Setup dummy array + do i=1,5 + dummy_arr(i) = 10 + enddo + + ! Write test file + if(rank == 0) then + open(newunit=iounit, iostat=stat, action='write', file=fname, & + form=form, access=access, status=status, position=position) + + write(iounit) true_real ! double + write(iounit) dummy_arr + write(iounit) true_integer ! int + + if (stat == 0) close(iounit) + endif + + call MPI_Barrier(MPI_COMM_WORLD) + + ! Read test file + call ioHandler%open(fname, err, \ + action='read', form=form, access=access, status=status, position=position) + HANDLE_ERROR(err) + + call ioHandler%read(in_real) + @assertTrue(in_real == true_real) + + call ioHandler%seek(size(dummy_arr)*sizeof(0)) + + call ioHandler%read(in_integer) + @assertTrue(in_integer == true_integer) + + call ioHandler%close() + + if(rank == 0) then + ! Cleanup test file + open(newunit=iounit, iostat=stat, action='read', file=fname) + if (stat == 0) close(iounit, status='delete') + endif + end subroutine + end module From 9150e266be529a2c9dcd5428b31265ce604a4d52 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Wed, 10 Nov 2021 10:51:18 +0000 Subject: [PATCH 55/66] Ensure we use the correct MPI wrapper with intel compilers --- makefile | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/makefile b/makefile index 73a28d7..a44a80e 100644 --- a/makefile +++ b/makefile @@ -36,6 +36,7 @@ ifeq ($(strip $(COMPILER)),intel) LAPACK = -mkl=parallel ifeq ($(USE_MPI),1) + FC=mpiifort LAPACK += -lmkl_scalapack_lp64 -lmkl_blacs_intelmpi_lp64 endif @@ -62,6 +63,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 ifneq ($(USE_MPI),0) # Assume we're using openmpi with gfortran + FC = mpif90 LAPACK += -lmkl_blacs_openmpi_lp64 -lmkl_scalapack_lp64 endif else @@ -71,7 +73,6 @@ endif CPPFLAGS = -D_EXTFIELD_DEBUG_ ifeq ($(USE_MPI),1) - FC = mpif90 FFLAGS += -DTROVE_USE_MPI_ endif From ecfac190cddb102c233b43be95a122f4dd545f9e Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 11 Nov 2021 14:31:25 +0000 Subject: [PATCH 56/66] Fix issue with differing offsets in different processes --- io_handler_mpi.f90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/io_handler_mpi.f90 b/io_handler_mpi.f90 index 4359426..8b0cef3 100644 --- a/io_handler_mpi.f90 +++ b/io_handler_mpi.f90 @@ -417,15 +417,20 @@ subroutine read2DArrayDistColumnMPI(this, object, dimen) ! Get individual pointer offset call MPI_File_get_position(this%fileh, offset, ierr) call MPI_File_get_byte_offset(this%fileh, offset, disp, ierr) + ! Set shared pointer to individual pointer + bookend call MPI_File_seek_shared(this%fileh, disp+this%bookendBytes, MPI_SEEK_SET, ierr) + ! Read array in parallel MPI_WRAPPER(MPI_File_read_ordered,this%fileh,object,1,mpitype_column,MPI_STATUS_IGNORE,ierr) + ! Set shared pointer to point to byte after last bookend call MPI_File_seek_shared(this%fileh, disp+this%bookendBytes+arrSizeBytes+this%bookendBytes, MPI_SEEK_SET) ! Set individual pointer to match shared call MPI_File_get_position_shared(this%fileh, offset, ierr) + ! Ensure every process syncs the correct shared offset + call MPI_Barrier(MPI_COMM_WORLD) call MPI_File_seek(this%fileh, offset, MPI_SEEK_SET, ierr) end subroutine From 57adeed39a9673e77574ebef6207c638f889ee40 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 11 Nov 2021 15:15:52 +0000 Subject: [PATCH 57/66] Move MPI split errorto correct place --- perturbation.f90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/perturbation.f90 b/perturbation.f90 index 91c9868..baeaf3f 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -15527,8 +15527,8 @@ subroutine PTcontracted_matelem_class(jrot) if (job%IOmatelem_split) then ! ! TODO fix MPIIO matelem split - stop "Split not implemented yet - TODO" if (trim(job%kinetmat_format).eq.'MPIIO') then + stop "Split not implemented yet - TODO" call write_divided_slice_mpi(islice,'g_rot',job%matelem_suffix,mdimen,grot_t) else call write_divided_slice(islice,'g_rot',job%matelem_suffix,mdimen,grot_t) From 9c3b88a337f08185845a3c2f18e23e27606479bd Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 11 Nov 2021 17:22:48 +0000 Subject: [PATCH 58/66] Transition MPIIO slice implementation to use ioHandlers --- perturbation.f90 | 106 ++++++++++++++++++++--------------------------- 1 file changed, 44 insertions(+), 62 deletions(-) diff --git a/perturbation.f90 b/perturbation.f90 index baeaf3f..107dafe 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -15160,7 +15160,8 @@ subroutine PTcontracted_matelem_class(jrot) integer :: startdim, enddim, blocksize_, ierr, b, req_count, offset type(MPI_Request),allocatable :: reqs(:) type(MPI_Status) :: reqstat - type(MPI_File) :: chkptMPIIO, chkptMPIIO_ + type(MPI_File) :: chkptMPIIO + class(ioHandlerBase), allocatable :: sliceHandler integer(kind=MPI_Offset_kind) :: mpioffset integer :: mpisz ! @@ -15526,9 +15527,7 @@ subroutine PTcontracted_matelem_class(jrot) if (trim(job%IOkinet_action)=='SAVE') then if (job%IOmatelem_split) then ! - ! TODO fix MPIIO matelem split if (trim(job%kinetmat_format).eq.'MPIIO') then - stop "Split not implemented yet - TODO" call write_divided_slice_mpi(islice,'g_rot',job%matelem_suffix,mdimen,grot_t) else call write_divided_slice(islice,'g_rot',job%matelem_suffix,mdimen,grot_t) @@ -15960,9 +15959,9 @@ subroutine PTcontracted_matelem_class(jrot) ! !! TODO !! write(*,*) "TODO: NEEDS VERIFICATION" - call divided_slice_open_mpi(islice,chkptMPIIO_,'g_vib',job%matelem_suffix) + call divided_slice_open_mpi(islice,sliceHandler,'g_vib',job%matelem_suffix) ! - call co_read_matrix_distr_ordered(gvib_t, mdimen, startdim, enddim, chkptMPIIO_) + call sliceHandler%read(gvib_t, mdimen) ! do b=1,comm_size if (send_or_recv(b).ge.0) then @@ -15976,7 +15975,7 @@ subroutine PTcontracted_matelem_class(jrot) endif enddo ! - call divided_slice_close_mpi(islice,chkptMPIIO_,'g_vib') + call divided_slice_close_mpi(islice,sliceHandler,'g_vib') ! enddo else @@ -16380,37 +16379,29 @@ subroutine write_divided_slice_mpi(islice,name,suffix,N,field) integer(ik),intent(in) :: N real(rk),dimension(:,:),intent(in) :: field -#ifdef TROVE_USE_MPI_ character(len=4) :: jchar character(len=cl) :: filename - character(len=cl) :: job_is - type(MPI_File) :: chkptMPIIO - integer(kind=MPI_OFFSET_KIND) :: offset + character(len=cl) :: job_id + class(ioHandlerBase), allocatable :: ioHandler integer :: ierr ! - write(job_is,"('single swap_matrix')") + write(job_id,"('single swap_matrix')") ! - !!call IOStart(trim(job_is),chkptIO) + !!call IOStart(trim(job_id),chkptIO) ! write(jchar, '(i4)') islice ! filename = trim(suffix)//trim(adjustl(jchar))//'.chk' ! - offset = 0 - call MPI_File_open(mpi_comm_world, filename, mpi_mode_wronly+mpi_mode_create, mpi_info_null, chkptMPIIO, ierr) - call MPI_File_set_size(chkptMPIIO, offset, ierr) - call mpi_barrier(mpi_comm_world, ierr) - ! - if(mpi_rank .eq. 0) call MPI_File_write_shared(chkptMPIIO,name,len(trim(name)),mpi_character,mpi_status_ignore,ierr) - call mpi_barrier(mpi_comm_world, ierr) - ! - call co_write_matrix_distr(field, N, co_startdim, co_enddim,chkptMPIIO) - ! - if(mpi_rank .eq. 0) call MPI_File_write_shared(chkptMPIIO,name,len(trim(name)),mpi_character,mpi_status_ignore,ierr) - ! - call MPI_File_close(chkptMPIIO, ierr) - ! -#endif + call openFile(ioHandler, filename, err, action='write', & + form='unformatted',position='rewind',status='replace') + HANDLE_ERROR(err) + + call ioHandler%write(name) + call ioHandler%write(field, N) + call ioHandler%write(name) + + deallocate(ioHandler) end subroutine write_divided_slice_mpi @@ -16452,46 +16443,42 @@ subroutine divided_slice_open(islice,chkptIO,name,suffix) ! end subroutine divided_slice_open - subroutine divided_slice_open_mpi(islice,chkptIO,name,suffix) + subroutine divided_slice_open_mpi(islice,ioHandler,name,suffix) ! implicit none integer(ik),intent(in) :: islice - type(MPI_File),intent(inout) :: chkptIO + class(ioHandlerBase),intent(inout), allocatable :: ioHandler character(len=*),intent(in) :: name,suffix -#ifdef TROVE_USE_MPI_ character(len=4) :: jchar - character(len=cl) :: buf,filename,job_is + character(len=cl) :: buf,filename,job_id integer(ik) :: ilen integer :: ierr ! if (.not.job%IOmatelem_split) return ! - write(job_is,"('single swap_matrix')") + write(job_id,"('single swap_matrix')") ! !!call IOStart(trim(job_is),chkptIO) ! write(jchar, '(i4)') islice ! filename = trim(suffix)//trim(adjustl(jchar))//'.chk' - ! - call MPI_File_open(mpi_comm_world, filename, mpi_mode_rdonly, mpi_info_null, chkptMPIIO, ierr) - if (ierr.ne.0) then - if(mpi_rank.eq.0) write(out,"('divided_slice_open-error: The split-file ',a,' does not exist')") trim(filename) - stop 'divided_slice_open-error: The split-file does not exist' - endif + + call openFile(ioHandler, filename, err, action='read', & + form='unformatted',position='rewind',status='old') + HANDLE_ERROR(err) ! ilen = LEN_TRIM(name) - ! - if (mpi_rank.eq.0) then - call MPI_File_read_shared(chkptIO, buf, ilen, mpi_character, mpi_status_ignore, ierr) - if ( trim(buf(1:ilen))/=trim(name) ) then - write (out,"(' kinetic checkpoint slice ',a20,': header is missing or wrong',a)") filename,buf(1:ilen) - call MPI_Abort(mpi_comm_world, 1) - !stop 'PTrestore_rot_kinetic_matrix_elements - in slice - header missing or wrong' - endif - endif + + call ioHandler%read(buf(1:ilen)) + if ( trim(buf(1:ilen))/=trim(name) ) then + write (out,"(' kinetic checkpoint slice ',a20,': header is missing or wrong',a)") filename,buf(1:ilen) +#ifdef TROVE_USE_MPI_ + call MPI_Abort(mpi_comm_world, 1) #endif + stop 'PTrestore_rot_kinetic_matrix_elements - in slice - header missing or wrong' + endif end subroutine divided_slice_open_mpi ! subroutine divided_slice_close(islice,chkptIO,name) @@ -16518,10 +16505,10 @@ subroutine divided_slice_close(islice,chkptIO,name) ! end subroutine divided_slice_close - subroutine divided_slice_close_mpi(islice,chkptIO,name) - ! + subroutine divided_slice_close_mpi(islice,ioHandler,name) + integer(ik),intent(in) :: islice - type(MPI_File),intent(inout) :: chkptIO + class(ioHandlerBase),intent(inout), allocatable :: ioHandler character(len=*),intent(in) :: name character(len=cl) :: buf integer(ik) :: ilen @@ -16531,21 +16518,16 @@ subroutine divided_slice_close_mpi(islice,chkptIO,name) ! ilen = LEN_TRIM(name) ! - if(mpi_rank .eq. 0) then -#ifdef TROVE_USE_MPI_ - call MPI_File_read_shared(chkptIO, buf, ilen, mpi_character, mpi_status_ignore, ierr) - if ( trim(buf(1:ilen))/=trim(name) ) then + call ioHandler%read(buf(1:ilen)) + if ( trim(buf(1:ilen))/=trim(name) ) then write (out,"(' divided_slice_close, kinetic checkpoint slice ',a,': footer is missing or wrong',a)") trim(name),buf(1:ilen) - call MPI_Abort(mpi_comm_world, 1) - !stop 'divided_slice_close - in slice - footer missing or wrong' - endif -#endif - endif - ! #ifdef TROVE_USE_MPI_ - call MPI_File_close(chkptIO, ierr) + call MPI_Abort(mpi_comm_world, 1) #endif - ! + stop 'PTrestore_rot_kinetic_matrix_elements - in slice - footer missing or wrong' + endif + + deallocate(ioHandler) end subroutine divided_slice_close_mpi ! From a6534675c9fcec6317f87482414b839c620bd6ad Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 11 Nov 2021 17:41:22 +0000 Subject: [PATCH 59/66] Use only one call for handling slice read/write --- perturbation.f90 | 322 ++++++++++++++--------------------------------- 1 file changed, 92 insertions(+), 230 deletions(-) diff --git a/perturbation.f90 b/perturbation.f90 index 107dafe..7f0bd27 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -8622,9 +8622,9 @@ subroutine PTrestore_rot_kinetic_matrix_elements(jrot, task, ioHandler, dimen, & ! call co_create_distr_array(grot(k1,k2)%me, ncontr) ! - call divided_slice_open_mpi(islice,sliceHandler,'g_rot',job%matelem_suffix) + call divided_slice_open(islice,sliceHandler,'g_rot',job%matelem_suffix) call sliceHandler%read(grot(k1,k2)%me, ncontr) - call divided_slice_close_mpi(islice,sliceHandler,'g_rot') + call divided_slice_close(islice,sliceHandler,'g_rot') ! enddo enddo @@ -8669,9 +8669,9 @@ subroutine PTrestore_rot_kinetic_matrix_elements(jrot, task, ioHandler, dimen, & ! call co_create_distr_array(gcor(k1)%me, ncontr) ! - call divided_slice_open_mpi(islice,sliceHandler,'g_cor',job%matelem_suffix) + call divided_slice_open(islice,sliceHandler,'g_cor',job%matelem_suffix) call sliceHandler%read(gcor(k1)%me, ncontr) - call divided_slice_close_mpi(islice,sliceHandler,'g_cor') + call divided_slice_close(islice,sliceHandler,'g_cor') enddo ! endif @@ -8961,7 +8961,7 @@ subroutine divided_slice_close_vib_rot(islice,name,chkptIO) ! end subroutine divided_slice_close_vib_rot - subroutine divided_slice_open_mpi(islice,sliceHandler,chkpt_type,suffix) + subroutine divided_slice_open(islice,sliceHandler,chkpt_type,suffix) use mpi_aux implicit none integer(ik),intent(in) :: islice @@ -8994,9 +8994,9 @@ subroutine divided_slice_open_mpi(islice,sliceHandler,chkpt_type,suffix) if (mpi_rank .eq. 0) write (out,"('divided_slice_open, kinetic checkpoint slice ',a20,': header is missing or wrong',a)") filename,readbuf(1:ilen) stop 'PTrestore_rot_kinetic_matrix_elements- in slice - header missing or wrong' end if - end subroutine divided_slice_open_mpi + end subroutine divided_slice_open - subroutine divided_slice_close_mpi(islice,sliceHandler,chkpt_type) + subroutine divided_slice_close(islice,sliceHandler,chkpt_type) use mpi_aux integer(ik),intent(in) :: islice class(ioHandlerBase), allocatable, intent(inout) :: sliceHandler @@ -9017,7 +9017,7 @@ subroutine divided_slice_close_mpi(islice,sliceHandler,chkpt_type) stop 'divided_slice_close - in slice - footer missing or wrong' end if deallocate(sliceHandler) - end subroutine divided_slice_close_mpi + end subroutine divided_slice_close end subroutine ! @@ -15527,11 +15527,7 @@ subroutine PTcontracted_matelem_class(jrot) if (trim(job%IOkinet_action)=='SAVE') then if (job%IOmatelem_split) then ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - call write_divided_slice_mpi(islice,'g_rot',job%matelem_suffix,mdimen,grot_t) - else - call write_divided_slice(islice,'g_rot',job%matelem_suffix,mdimen,grot_t) - endif + call write_divided_slice(islice,'g_rot',job%matelem_suffix,mdimen,grot_t) ! else ! @@ -15612,11 +15608,7 @@ subroutine PTcontracted_matelem_class(jrot) ! if (job%IOmatelem_divide) then ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - call write_divided_slice_mpi(islice,'g_cor',job%matelem_suffix,mdimen,grot_t) - else - call write_divided_slice(islice,'g_cor',job%matelem_suffix,mdimen,grot_t) - endif + call write_divided_slice(islice,'g_cor',job%matelem_suffix,mdimen,grot_t) ! else ! @@ -15634,11 +15626,7 @@ subroutine PTcontracted_matelem_class(jrot) ! if (job%IOmatelem_split) then ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - call write_divided_slice_mpi(islice,'g_cor',job%matelem_suffix,mdimen,gcor_t) - else - call write_divided_slice(islice,'g_cor',job%matelem_suffix,mdimen,gcor_t) - endif + call write_divided_slice(islice,'g_cor',job%matelem_suffix,mdimen,gcor_t) ! else ! @@ -15843,11 +15831,7 @@ subroutine PTcontracted_matelem_class(jrot) enddo !$omp end parallel do ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - call write_divided_slice_mpi(islice,'g_vib',job%matelem_suffix,mdimen,gvib_t) - else - call write_divided_slice(islice,'g_vib',job%matelem_suffix,mdimen,gvib_t) - endif + call write_divided_slice(islice,'g_vib',job%matelem_suffix,mdimen,gvib_t) ! else ! @@ -15930,11 +15914,7 @@ subroutine PTcontracted_matelem_class(jrot) ! islice = (PT%Nmodes+3)*3+PT%Nmodes**2+1 ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - call write_divided_slice_mpi(islice,'g_vib',job%matelem_suffix,mdimen,gvib_t) - else - call write_divided_slice(islice,'g_vib',job%matelem_suffix,mdimen,gvib_t) - endif + call write_divided_slice(islice,'g_vib',job%matelem_suffix,mdimen,gvib_t) ! if (job%IOmatelem_split.and.job%iswap(1)==1) job%iswap(1)=0 ! @@ -15952,53 +15932,32 @@ subroutine PTcontracted_matelem_class(jrot) ! f_t = -0.5_rk ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - do islice = iterm1,iterm2 - ! - if (islice==(PT%Nmodes+3)*3+PT%Nmodes**2+1) f_t = 1.0_rk - ! - !! TODO !! - write(*,*) "TODO: NEEDS VERIFICATION" - call divided_slice_open_mpi(islice,sliceHandler,'g_vib',job%matelem_suffix) - ! - call sliceHandler%read(gvib_t, mdimen) - ! - do b=1,comm_size - if (send_or_recv(b).ge.0) then - !$omp parallel do private(icoeff,jcoeff) shared(b,grot_t) schedule(static) - do icoeff=startdim,enddim - do jcoeff=((b-1)*mdimen_p)+1,b*mdimen_p - if (jcoeff .gt. PT%Maxcontracts) cycle - hvib_t(jcoeff,icoeff) = hvib_t(jcoeff,icoeff)+f_t*gvib_t(jcoeff,icoeff) - enddo + do islice = iterm1,iterm2 + ! + if (islice==(PT%Nmodes+3)*3+PT%Nmodes**2+1) f_t = 1.0_rk + ! +#ifdef TROVE_USE_MPI_ + write(out,*) "WARNING: slice handling of g_vib using MPI is unverified" +#endif + call divided_slice_open(islice,sliceHandler,'g_vib',job%matelem_suffix) + ! + call sliceHandler%read(gvib_t, mdimen) + ! + do b=1,comm_size + if (send_or_recv(b).ge.0) then + !$omp parallel do private(icoeff,jcoeff) shared(b,grot_t) schedule(static) + do icoeff=startdim,enddim + do jcoeff=((b-1)*mdimen_p)+1,b*mdimen_p + if (jcoeff .gt. PT%Maxcontracts) cycle + hvib_t(jcoeff,icoeff) = hvib_t(jcoeff,icoeff)+f_t*gvib_t(jcoeff,icoeff) enddo - endif - enddo - ! - call divided_slice_close_mpi(islice,sliceHandler,'g_vib') - ! - enddo - else - do islice = iterm1,iterm2 - ! - if (islice==(PT%Nmodes+3)*3+PT%Nmodes**2+1) f_t = 1.0_rk - ! - call divided_slice_open(islice,chkptIO_,'g_vib',job%matelem_suffix) - ! - read(chkptIO_) gvib_t - ! - !$omp parallel do private(icoeff,jcoeff) shared(hvib_t) schedule(dynamic) - do icoeff=1,mdimen - do jcoeff=1,icoeff - hvib_t(jcoeff,icoeff) = hvib_t(jcoeff,icoeff)+f_t*gvib_t(jcoeff,icoeff) - enddo - enddo - !$omp end parallel do - ! - call divided_slice_close(islice,chkptIO_,'g_vib') - ! + enddo + endif enddo - endif + ! + call divided_slice_close(islice,sliceHandler,'g_vib') + ! + enddo ! gvib_t = 0 ! @@ -16168,11 +16127,7 @@ subroutine PTcontracted_matelem_class(jrot) ! if (job%IOextF_divide) then ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - call write_divided_slice_mpi(imu,'extF',job%extmat_suffix,mdimen,extF_t) - else - call write_divided_slice(imu,'extF',job%extmat_suffix,mdimen,extF_t) - endif + call write_divided_slice(imu,'extF',job%extmat_suffix,mdimen,extF_t) ! else ! @@ -16339,40 +16294,10 @@ subroutine PTcontracted_matelem_class(jrot) ! stop 'cannot proceede for extF = divide-join with matelem /= read' !endif ! + contains subroutine write_divided_slice(islice,name,suffix,N,field) - ! - integer(ik),intent(in) :: islice - character(len=*),intent(in) :: name,suffix - integer(ik),intent(in) :: N - real(rk),intent(in) :: field(N,N) - character(len=4) :: jchar - integer(ik) :: chkptIO - character(len=cl) :: filename - character(len=cl) :: job_is - ! - write(job_is,"('single swap_matrix')") - ! - call IOStart(trim(job_is),chkptIO) - ! - write(jchar, '(i4)') islice - ! - filename = trim(suffix)//trim(adjustl(jchar))//'.chk' - ! - open(chkptIO,form='unformatted',action='write',position='rewind',status='replace',file=filename) - ! - write(chkptIO) trim(name) - ! - write(chkptIO) field - ! - write(chkptIO) trim(name) - ! - close(chkptIO) - ! - end subroutine write_divided_slice - - subroutine write_divided_slice_mpi(islice,name,suffix,N,field) ! integer(ik),intent(in) :: islice character(len=*),intent(in) :: name,suffix @@ -16402,133 +16327,70 @@ subroutine write_divided_slice_mpi(islice,name,suffix,N,field) call ioHandler%write(name) deallocate(ioHandler) - end subroutine write_divided_slice_mpi - - - subroutine divided_slice_open(islice,chkptIO,name,suffix) - ! - implicit none - integer(ik),intent(in) :: islice - integer(ik),intent(inout) :: chkptIO - character(len=*),intent(in) :: name,suffix - character(len=4) :: jchar - character(len=cl) :: buf,filename,job_is - integer(ik) :: ilen - logical :: ifopened - ! - if (.not.job%IOmatelem_split) return - ! - write(job_is,"('single swap_matrix')") - ! - call IOStart(trim(job_is),chkptIO) - ! - write(jchar, '(i4)') islice - ! - filename = trim(suffix)//trim(adjustl(jchar))//'.chk' - ! - open(chkptIO,form='unformatted',action='read',position='rewind',status='old',file=filename,err=10) - ! - ilen = LEN_TRIM(name) - ! - read(chkptIO) buf(1:ilen) - if ( trim(buf(1:ilen))/=trim(name) ) then - write (out,"(' kinetic checkpoint slice ',a20,': header is missing or wrong',a)") filename,buf(1:ilen) - stop 'PTrestore_rot_kinetic_matrix_elements - in slice - header missing or wrong' - end if - ! - return - ! - 10 write(out,"('divided_slice_open-error: The split-file ',a,' does not exist')") trim(filename) - stop 'divided_slice_open-error: The split-file does not exist' - ! - end subroutine divided_slice_open + end subroutine write_divided_slice - subroutine divided_slice_open_mpi(islice,ioHandler,name,suffix) - ! - implicit none - integer(ik),intent(in) :: islice - class(ioHandlerBase),intent(inout), allocatable :: ioHandler - character(len=*),intent(in) :: name,suffix + subroutine divided_slice_open(islice,ioHandler,name,suffix) + ! + implicit none + integer(ik),intent(in) :: islice + class(ioHandlerBase),intent(inout), allocatable :: ioHandler + character(len=*),intent(in) :: name,suffix - character(len=4) :: jchar - character(len=cl) :: buf,filename,job_id - integer(ik) :: ilen - integer :: ierr - ! - if (.not.job%IOmatelem_split) return - ! - write(job_id,"('single swap_matrix')") - ! - !!call IOStart(trim(job_is),chkptIO) - ! - write(jchar, '(i4)') islice - ! - filename = trim(suffix)//trim(adjustl(jchar))//'.chk' + character(len=4) :: jchar + character(len=cl) :: buf,filename,job_id + integer(ik) :: ilen + integer :: ierr + ! + if (.not.job%IOmatelem_split) return + ! + write(job_id,"('single swap_matrix')") + ! + !!call IOStart(trim(job_is),chkptIO) + ! + write(jchar, '(i4)') islice + ! + filename = trim(suffix)//trim(adjustl(jchar))//'.chk' - call openFile(ioHandler, filename, err, action='read', & - form='unformatted',position='rewind',status='old') - HANDLE_ERROR(err) - ! - ilen = LEN_TRIM(name) + call openFile(ioHandler, filename, err, action='read', & + form='unformatted',position='rewind',status='old') + HANDLE_ERROR(err) + ! + ilen = LEN_TRIM(name) - call ioHandler%read(buf(1:ilen)) - if ( trim(buf(1:ilen))/=trim(name) ) then - write (out,"(' kinetic checkpoint slice ',a20,': header is missing or wrong',a)") filename,buf(1:ilen) + call ioHandler%read(buf(1:ilen)) + if ( trim(buf(1:ilen))/=trim(name) ) then + write (out,"(' kinetic checkpoint slice ',a20,': header is missing or wrong',a)") filename,buf(1:ilen) #ifdef TROVE_USE_MPI_ - call MPI_Abort(mpi_comm_world, 1) + call MPI_Abort(mpi_comm_world, 1) #endif - stop 'PTrestore_rot_kinetic_matrix_elements - in slice - header missing or wrong' - endif - end subroutine divided_slice_open_mpi - ! - subroutine divided_slice_close(islice,chkptIO,name) - ! - integer(ik),intent(in) :: islice - integer(ik),intent(inout) :: chkptIO - character(len=*),intent(in) :: name - character(len=4) :: jchar - character(len=cl) :: buf,filename - integer(ik) :: ilen - logical :: ifopened - ! - if (.not.job%IOmatelem_split) return - ! - ilen = LEN_TRIM(name) - ! - read(chkptIO) buf(1:ilen) - if ( trim(buf(1:ilen))/=trim(name) ) then - write (out,"(' divided_slice_close, kinetic checkpoint slice ',a,': footer is missing or wrong',a)") filename,buf(1:ilen) - stop 'divided_slice_close - in slice - footer missing or wrong' - end if - ! - close(chkptIO) - ! - end subroutine divided_slice_close + stop 'PTrestore_rot_kinetic_matrix_elements - in slice - header missing or wrong' + endif + end subroutine divided_slice_open - subroutine divided_slice_close_mpi(islice,ioHandler,name) + subroutine divided_slice_close(islice,ioHandler,name) - integer(ik),intent(in) :: islice - class(ioHandlerBase),intent(inout), allocatable :: ioHandler - character(len=*),intent(in) :: name - character(len=cl) :: buf - integer(ik) :: ilen - integer :: ierr - ! - if (.not.job%IOmatelem_split) return - ! - ilen = LEN_TRIM(name) - ! - call ioHandler%read(buf(1:ilen)) - if ( trim(buf(1:ilen))/=trim(name) ) then - write (out,"(' divided_slice_close, kinetic checkpoint slice ',a,': footer is missing or wrong',a)") trim(name),buf(1:ilen) + integer(ik),intent(in) :: islice + class(ioHandlerBase),intent(inout), allocatable :: ioHandler + character(len=*),intent(in) :: name + character(len=cl) :: buf + integer(ik) :: ilen + integer :: ierr + ! + if (.not.job%IOmatelem_split) return + ! + ilen = LEN_TRIM(name) + ! + call ioHandler%read(buf(1:ilen)) + if ( trim(buf(1:ilen))/=trim(name) ) then + write (out,"(' divided_slice_close, kinetic checkpoint slice ',a,': footer is missing or wrong',a)") trim(name),buf(1:ilen) #ifdef TROVE_USE_MPI_ - call MPI_Abort(mpi_comm_world, 1) + call MPI_Abort(mpi_comm_world, 1) #endif - stop 'PTrestore_rot_kinetic_matrix_elements - in slice - footer missing or wrong' - endif + stop 'PTrestore_rot_kinetic_matrix_elements - in slice - footer missing or wrong' + endif - deallocate(ioHandler) - end subroutine divided_slice_close_mpi + deallocate(ioHandler) + end subroutine divided_slice_close ! ! This procedure is thought to make the calculations of the contracted mat. elements From 6a5a9f5d2ab4639fba5691fc631d491bfe631999 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Fri, 12 Nov 2021 10:42:30 +0000 Subject: [PATCH 60/66] Fix unallocated array access --- tran.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tran.f90 b/tran.f90 index 175326c..a0bfce4 100644 --- a/tran.f90 +++ b/tran.f90 @@ -1393,10 +1393,10 @@ subroutine TRconvert_matel_j0_eigen(jrot) else call co_block_type_init(psi, Neigenroots, dimen, desc_psi, info) call ArrayStart('psi',info,1,kind(psi),int(size(psi),hik)) - + !shape(psi_t) == shape(psi^T) == shape(mat_t) call co_block_type_init(psi_t, dimen, Neigenroots, desc_mat_t, info) - call ArrayStart('psi_t',info,1,kind(mat_t),int(size(mat_t),hik)) + call ArrayStart('psi_t',info,1,kind(psi_t),int(size(psi_t),hik)) call co_block_type_init(mat_t, dimen, Neigenroots, desc_mat_t, info) call ArrayStart('mat_t',info,1,kind(mat_t),int(size(mat_t),hik)) endif From 034e4e46b89f11f02b77b458b7a60f5b36db8a45 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Fri, 12 Nov 2021 16:09:20 +0000 Subject: [PATCH 61/66] Use assumed size array for reading/writing slices. This fixes segfault. --- tran.f90 | 50 +++++++++++++++++++------------------------------- 1 file changed, 19 insertions(+), 31 deletions(-) diff --git a/tran.f90 b/tran.f90 index a0bfce4..92f5004 100644 --- a/tran.f90 +++ b/tran.f90 @@ -1691,7 +1691,7 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! if (job%IOmatelem_split.and..not.job%vib_rot_contr) then ! - call divided_slice_read(islice,'g_rot',job%matelem_suffix,dimen,gmat,desc_gmat,gmat_block_type,ierror) + call divided_slice_read(islice,'g_rot',job%matelem_suffix,gmat,desc_gmat,gmat_block_type,ierror) ! elseif (job%IOmatelem_split.and.job%vib_rot_contr) then ! @@ -1720,7 +1720,7 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! if (job%IOmatelem_split.and..not.job%vib_rot_contr) then ! - call divided_slice_write(islice,'g_rot',job%j0matelem_suffix,Neigenroots,mat_s, desc_mat_s,mat_s_block_type) + call divided_slice_write(islice,'g_rot',job%j0matelem_suffix,mat_s, desc_mat_s,mat_s_block_type) ! elseif (job%IOmatelem_split.and.job%vib_rot_contr) then ! @@ -1767,7 +1767,7 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! if (job%IOmatelem_split.and..not.job%vib_rot_contr) then ! - call divided_slice_read(islice,'g_cor',job%matelem_suffix,dimen,gmat,desc_gmat,gmat_block_type,ierror) + call divided_slice_read(islice,'g_cor',job%matelem_suffix,gmat,desc_gmat,gmat_block_type,ierror) ! elseif (job%IOmatelem_split.and.job%vib_rot_contr) then ! @@ -1798,7 +1798,7 @@ subroutine TRconvert_matel_j0_eigen(jrot) if(job%vib_rot_contr) then call divided_slice_write_vibrot(islice,job%j0matelem_suffix,Neigenroots,mat_s,desc_mat_s,mat_s_block_type) else - call divided_slice_write(islice,'g_cor',job%j0matelem_suffix,Neigenroots,mat_s,desc_mat_s,mat_s_block_type) + call divided_slice_write(islice,'g_cor',job%j0matelem_suffix,mat_s,desc_mat_s,mat_s_block_type) endif else call kineteigenHandler%write(mat_s, desc_mat_s, mat_s_block_type) @@ -1973,7 +1973,7 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! if (job%IOextF_divide) then ! - call divided_slice_read(imu,'extF',job%extmat_suffix,dimen,extF_me,desc_extF,extF_block_type,ierror) + call divided_slice_read(imu,'extF',job%extmat_suffix,extF_me,desc_extF,extF_block_type,ierror) ! if (ierror==1) cycle ! @@ -2066,7 +2066,7 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! else ! - call divided_slice_write(imu,'extF',job%j0extmat_suffix,Neigenroots,mat_s,desc_mat_s,mat_s_block_type) + call divided_slice_write(imu,'extF',job%j0extmat_suffix,mat_s,desc_mat_s,mat_s_block_type) ! endif ! @@ -2158,14 +2158,13 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! contains ! - subroutine divided_slice_write(islice,name,suffix,N,field, field_desc, block_type) + subroutine divided_slice_write(islice,name,suffix,field, field_desc, block_type) ! implicit none ! integer(ik),intent(in) :: islice character(len=*),intent(in) :: name,suffix - integer(ik),intent(in) :: N - real(rk),intent(in) :: field(N,N) + real(rk),intent(in) :: field(:,:) integer, intent(in) :: field_desc(9) type(MPI_Datatype),intent(in) :: block_type character(len=4) :: jchar @@ -2188,19 +2187,18 @@ subroutine divided_slice_write(islice,name,suffix,N,field, field_desc, block_typ ! call ioHandler%write(name) ! - close(chkptIO) + deallocate(ioHandler) ! end subroutine divided_slice_write ! ! - subroutine divided_slice_read(islice,name,suffix,N,field,field_desc,block_type,ierror) + subroutine divided_slice_read(islice,name,suffix,field,field_desc,block_type,ierror) ! implicit none ! integer(ik),intent(in) :: islice character(len=*),intent(in) :: name,suffix - integer(ik),intent(in) :: N - real(rk),intent(out) :: field(N,N) + real(rk),intent(out) :: field(:,:) integer, intent(in) :: field_desc(9) type(MPI_Datatype),intent(in) :: block_type integer(ik),intent(out) :: ierror @@ -2234,27 +2232,11 @@ subroutine divided_slice_read(islice,name,suffix,N,field,field_desc,block_type,i ! call ioHandler%read(buf(1:ilen)) if ( trim(buf(1:ilen))/=trim(name) ) then - write (out,"(' kinetic divided_slice_read in slice ',a20,': header is missing or wrong',a)") filename,buf(1:ilen) - stop 'divided_slice_read - in slice - header missing or wrong' + write (out,"(' kinetic divided_slice_read in slice ',a20,': footer is missing or wrong',a)") filename,buf(1:ilen) + stop 'divided_slice_read - in slice - footer missing or wrong' end if ! deallocate(ioHandler) - ! - return - ! - ! This error code will allow simply skipping the corresponding record/file without crashing the program - ! - 15 ierror = 1 - ! - ! we allow to skip opening the file only for the external matrix elements - ! - if (trim(name)/="extF") then - write (out,"(' kinetic divided_slice_read in slice ',a20,': file does not exist')") filename - stop 'divided_slice_read - in slice - file does not exist' - endif - ! - if (job%verbose>=4) write (out,"(' (skipped).')",advance='YES') - ! end subroutine divided_slice_read ! ! @@ -2274,6 +2256,12 @@ subroutine divided_slice_read_vibrot(islice,suffix,N,field,field_desc,block_type integer(ik) :: rec_len,icontr,icontr1,icontr2 logical :: ifopened real(rk) :: f_t + +#ifdef TROVE_USE_MPI_ + if(blacs_size > 1) then + stop "MPI output not implemented in tran.f90:divided_slice_read_vibrot" + endif +#endif ! if (.not.job%IOmatelem_split) return ! From 3d185e70f841994156eae9b98c2b958bc742e279 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Tue, 4 Jan 2022 11:30:58 +0000 Subject: [PATCH 62/66] Fix mismatch in integer kind passed to file seek --- test/unit/test_mpi_io.pf | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/test/unit/test_mpi_io.pf b/test/unit/test_mpi_io.pf index 66b1b87..7830625 100644 --- a/test/unit/test_mpi_io.pf +++ b/test/unit/test_mpi_io.pf @@ -601,6 +601,8 @@ module test_mpi_io integer :: ierr, rank, allocinfo = 0 type(ErrorType) :: err + integer(kind=4) :: offset + ! Set up MPI call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr) if(ierr.ne.0) print *, "Error: could not get rank" @@ -632,7 +634,8 @@ module test_mpi_io call ioHandler%read(in_real) @assertTrue(in_real == true_real) - call ioHandler%seek(size(dummy_arr)*sizeof(0)) + offset = size(dummy_arr)*sizeof(0) + call ioHandler%seek(offset) call ioHandler%read(in_integer) @assertTrue(in_integer == true_integer) From 2f5a5727c5d7ce651bc30262dd598c477594a3ec Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 11 Nov 2021 18:16:39 +0000 Subject: [PATCH 63/66] Transition MPIIO implementation of external matelem handling to use ioHandlers --- perturbation.f90 | 121 +++++++++++++++-------------------------------- tran.f90 | 77 ++++++++---------------------- 2 files changed, 60 insertions(+), 138 deletions(-) diff --git a/perturbation.f90 b/perturbation.f90 index 7f0bd27..ad0f38a 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -8059,7 +8059,7 @@ subroutine PThamiltonian_contract(jrot) call TimerStop('Calculating the Hamiltonian matrix') ! if (job%verbose>=4) write(out,"('...done!')") - if (mpi_rank.eq.0) then!mpiio + if (mpi_rank.eq.0) then do isym = 1,sym%Nrepresen if (.not.job%select_gamma(isym)) cycle enddo @@ -8399,7 +8399,7 @@ subroutine PThamiltonian_contract(jrot) endif ! enddo - endif!mpiio + endif ! if ( trim(job%IOeigen_action)=='SAVE'.or.trim(job%IOeigen_action)=='APPEND' ) then ! @@ -15160,8 +15160,9 @@ subroutine PTcontracted_matelem_class(jrot) integer :: startdim, enddim, blocksize_, ierr, b, req_count, offset type(MPI_Request),allocatable :: reqs(:) type(MPI_Status) :: reqstat - type(MPI_File) :: chkptMPIIO + class(ioHandlerBase), allocatable :: ioHandler class(ioHandlerBase), allocatable :: sliceHandler + class(ioHandlerBase), allocatable :: extFmatHandler integer(kind=MPI_Offset_kind) :: mpioffset integer :: mpisz ! @@ -15181,7 +15182,6 @@ 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 ! ! @@ -15698,39 +15698,35 @@ subroutine PTcontracted_matelem_class(jrot) if (job%verbose>=2) write(out,"('...end!')") ! if (treat_rotation.and.trim(job%IOkinet_action)=='SAVE') then - if (trim(job%kinetmat_format).eq.'MPIIO') then - write(out,*) "TODO implement MPI-IO version !POSIXIO!" - stop "Not yet implemented" - else - ! - ! store the rotational matrix elements - ! - call ioHandler%write('g_rot') - ! - do k1 = 1,3 - do k2 = 1,3 - ! - call ioHandler%write(grot_(k1,k2,:,:), mdimen_) - ! - enddo + write(out,*) "WARNING: MPI verion of treat_rotation is not verified" + ! + ! store the rotational matrix elements + ! + call ioHandler%write('g_rot') + ! + do k1 = 1,3 + do k2 = 1,3 + ! + call ioHandler%write(grot_(k1,k2,:,:), mdimen_) + ! enddo - ! - call ioHandler%write('g_cor') - ! - ! store the Coriolis matrix elements - ! - do k1 = 1,PT%Nmodes - do k2 = 1,3 - ! - call ioHandler%write(gcor_(k1,k2,:,:), mdimen_) - ! - enddo + enddo + ! + call ioHandler%write('g_cor') + ! + ! store the Coriolis matrix elements + ! + do k1 = 1,PT%Nmodes + do k2 = 1,3 + ! + call ioHandler%write(gcor_(k1,k2,:,:), mdimen_) + ! enddo - ! - deallocate(grot_,gcor_) - call ArrayStop('grot-gcor-fields') - ! - endif + enddo + ! + deallocate(grot_,gcor_) + call ArrayStop('grot-gcor-fields') + ! endif ! else ! if (.not.job%IOmatelem_split.or.job%iswap(1)==0 ) then @@ -16046,32 +16042,12 @@ subroutine PTcontracted_matelem_class(jrot) ! job_is ='external field contracted matrix elements for J=0' if (trim(job%kinetmat_format).eq.'MPIIO') then -#ifdef TROVE_USE_MPI_ - call MPI_File_open(mpi_comm_world, job%extFmat_file, mpi_mode_wronly+mpi_mode_create, mpi_info_null, chkptMPIIO, ierr) - mpioffset=0 - call MPI_File_set_size(chkptMPIIO, mpioffset, ierr) - if (mpi_rank.eq.0) then !AT - call TimerStart('mpiiosingle') !AT + call openFile(extFmatHandler, job%extFmat_file, err, action='write', & + form='unformatted',position='rewind',status='replace') + HANDLE_ERROR(err) - call MPI_File_write_shared(chkptMPIIO,'[MPIIO]Start external field',27,mpi_character,mpi_status_ignore,ierr) - !call MPI_File_write_shared(chkptMPIIO,'Start external field',20,mpi_character,mpi_status_ignore,ierr) - call MPI_File_write_shared(chkptMPIIO, PT%Maxcontracts, 1, mpi_integer, mpi_status_ignore, ierr) - ! - ! store the bookkeeping information about the contr. basis set - ! - !call PTstoreMPI_icontr_cnu(PT%Maxcontracts,chkptMPIIO,job%IOkinet_action) - - call TimerStop('mpiiosingle') !AT - ! - !else - ! call TimerStart('mpiiosingle') !AT - ! ! - ! call MPI_File_write_shared(chkptMPIIO,'',0,mpi_character,mpi_status_ignore,ierr) - ! call MPI_File_write_shared(chkptMPIIO,'',0,mpi_character,mpi_status_ignore,ierr) - ! ! - ! call TimerStop('mpiiosingle') !AT - endif -#endif + call extFmatHandler%write('Start external field') + call extFmatHandler%write(PT%Maxcontracts) else call IOStart(trim(job_is),chkptIO) ! @@ -16134,14 +16110,8 @@ subroutine PTcontracted_matelem_class(jrot) ! always store the matrix elements of the extF moment ! if (trim(job%kinetmat_format).eq.'MPIIO') then -#ifdef TROVE_USE_MPI_ - if(mpi_rank.eq.0) then - call MPI_File_write_shared(chkptMPIIO,imu,1,mpi_integer,mpi_status_ignore,ierr) - endif - !call mpi_barrier(mpi_comm_world,ierr) - ! - call co_write_matrix_distr(extF_t,mdimen, startdim, enddim,chkptMPIIO) -#endif + call extFmatHandler%write(imu) + call extFmatHandler%write(extF_t, mdimen) else write(chkptIO) imu ! @@ -16189,21 +16159,8 @@ subroutine PTcontracted_matelem_class(jrot) ! endif ! -#ifdef TROVE_USE_MPI_ - call mpi_barrier(mpi_comm_world,ierr) -#endif if (trim(job%kinetmat_format).eq.'MPIIO') then -#ifdef TROVE_USE_MPI_ - if (mpi_rank.eq.0) then !AT - if(.not.job%IOextF_divide) then - !call MPI_File_seek(chkptMPIIO, mpioffset, MPI_SEEK_END) - call MPI_File_write_shared(chkptMPIIO,'End external field',18,mpi_character,mpi_status_ignore,ierr) - !else - ! call MPI_File_write_shared(chkptMPIIO,'',0,mpi_character,mpi_status_ignore,ierr) - endif - endif - call MPI_File_close(chkptMPIIO, ierr) -#endif + if (.not.job%IOextF_divide) call extFmatHandler%write('End external field') else if (.not.job%IOextF_divide) write(chkptIO) 'End external field' endif diff --git a/tran.f90 b/tran.f90 index 92f5004..c5268d4 100644 --- a/tran.f90 +++ b/tran.f90 @@ -1329,6 +1329,8 @@ subroutine TRconvert_matel_j0_eigen(jrot) integer :: ierr class(ioHandlerBase), allocatable :: kineteigenHandler class(ioHandlerBase), allocatable :: kinetmatHandler + class(ioHandlerBase), allocatable :: extFmatHandler + class(ioHandlerBase), allocatable :: exteigenHandler type(ErrorType) :: err type(MPI_Datatype) :: gmat_block_type, psi_block_type, mat_t_block_type, mat_s_block_type, extF_block_type @@ -1858,30 +1860,22 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! if (trim(job%kinetmat_format).eq.'MPIIO') then ! -#ifdef TROVE_USE_MPI_ - call MPI_File_open(mpi_comm_world, filename, mpi_mode_rdonly, mpi_info_null, fileh, ierr) - ! - call MPI_File_read_all(fileh, buf20, 7, mpi_character, mpi_status_ignore, ierr) - if (buf20(1:7)/='[MPIIO]') then - write (out,"(' Vib. kinetic checkpoint file ',a,' is not an MPIIO file: ',a)") filename, buf20 - stop 'restore_vib_matric_elements - Not an MPIIO file' - end if - ! - call MPI_File_read_all(fileh, buf20, 20, mpi_character, mpi_status_ignore, ierr) + call openFile(extFmatHandler, filename, err, action='read', & + form='unformatted',position='rewind',status='old') + HANDLE_ERROR(err) + + call extFmatHandler%read(buf20(1:20)) if (buf20/='Start external field') then write (out,"(' restore_vib_matrix_elements ',a,' has bogus header: ',a)") filename,buf20 stop 'restore_vib_matrix_elements - bogus file format' end if - ! - call MPI_File_read_all(fileh, ncontr_t, 1, mpi_integer, mpi_status_ignore, ierr) - ! + + call extFmatHandler%read(ncontr_t) if (bset_contr(1)%Maxcontracts/=ncontr_t) then write (out,"(' Dipole moment checkpoint file ',a)") filename write (out,"(' Actual and stored basis sizes at J=0 do not agree ',2i8)") bset_contr(1)%Maxcontracts,ncontr_t stop 'restore_Extvib_matrix_elements - in file - illegal ncontracts ' end if - ! -#endif else open(iunit,form='unformatted',action='read',position='rewind',status='old',file=filename) ! @@ -1910,26 +1904,11 @@ subroutine TRconvert_matel_j0_eigen(jrot) call IOStart(trim(job_is),chkptIO) ! if (trim(job%kinetmat_format).eq.'MPIIO') then -#ifdef TROVE_USE_MPI_ - ! - call mpi_file_open(mpi_comm_world, job%exteigen_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_shared(fileh_w, '[MPIIO]', 7, mpi_character, mpi_status_ignore, ierr) - call mpi_file_write_shared(fileh_w, 'Start external field', 20, mpi_character, mpi_status_ignore, ierr) - endif - ! - ! store the matrix elements - ! - if(mpi_rank.eq.0) call mpi_file_write(fileh_w, neigenroots, 1, mpi_integer, mpi_status_ignore, ierr) - call mpi_barrier(mpi_comm_world, ierr) - call mpi_file_seek(fileh_w, int(0,mpi_offset_kind), mpi_seek_end) - ! -#endif + call openFile(exteigenHandler, job%exteigen_file, err, action='write', & + form='unformatted',position='rewind',status='replace') + HANDLE_ERROR(err) + call exteigenHandler%write('Start external field') + call exteigenHandler%write(neigenroots) else ! open(chkptio,form='unformatted',action='write',position='rewind',status='replace',file=job%exteigen_file) @@ -1982,11 +1961,8 @@ subroutine TRconvert_matel_j0_eigen(jrot) else ! if (trim(job%kinetmat_format).eq.'MPIIO') then -#ifdef TROVE_USE_MPI_ - call MPI_File_read_all(fileh, imu_t, 1, mpi_integer, mpi_status_ignore, ierr) - ! - call MPI_File_read_all(fileh, extF_me, size(extF_me), mpi_double_precision, mpi_status_ignore, ierr) -#endif + call extFmatHandler%read(imu_t) + call extFmatHandler%read(extF_me) else read(iunit) imu_t ! @@ -2053,12 +2029,7 @@ subroutine TRconvert_matel_j0_eigen(jrot) if (.not.job%IOextF_divide.or.job%IOextF_stitch) then ! if (trim(job%kinetmat_format).eq.'MPIIO') then -#ifdef TROVE_USE_MPI_ - if(mpi_rank.eq.0) call MPI_File_write(fileh_w, imu, 1, mpi_integer, 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_File_write_all(fileh_w, mat_s, size(mat_s), mpi_double_precision, mpi_status_ignore, ierr) -#endif + call exteigenHandler%write(mat_s) else write(chkptIO) imu write(chkptIO) mat_s @@ -2093,9 +2064,7 @@ subroutine TRconvert_matel_j0_eigen(jrot) if (.not.job%IOextF_divide) then ! if (trim(job%kinetmat_format).eq.'MPIIO') then -#ifdef TROVE_USE_MPI_ - call MPI_File_read_all(fileh, buf20, 18, mpi_character, mpi_status_ignore, ierr) -#endif + call extFmatHandler%read(buf20(1:18)) else read(iunit) buf20(1:18) endif @@ -2106,9 +2075,7 @@ subroutine TRconvert_matel_j0_eigen(jrot) end if ! if (trim(job%kinetmat_format).eq.'MPIIO') then -#ifdef TROVE_USE_MPI_ - call MPI_File_close(fileh, ierr) -#endif + deallocate(extFmatHandler) else close(iunit,status='keep') endif @@ -2121,10 +2088,8 @@ subroutine TRconvert_matel_j0_eigen(jrot) if (.not.job%IOextF_divide.or.job%IOextF_stitch) then ! if (trim(job%kinetmat_format).eq.'MPIIO') then -#ifdef TROVE_USE_MPI_ - if(mpi_rank.eq.0) call MPI_File_write(fileh_w, 'End external field', 18, mpi_character, mpi_status_ignore, ierr) - call MPI_File_close(fileh_w, ierr) -#endif + call exteigenHandler%write('End external field') + deallocate(exteigenHandler) else write(chkptIO) 'End external field' close(chkptIO,status='keep') From f9b6d448294d1a755f769d841544f5f7ff9b1904 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Thu, 11 Nov 2021 18:29:31 +0000 Subject: [PATCH 64/66] Ensure external field handling is same for MPI and non-MPI versions of TROVE --- perturbation.f90 | 37 ++++------------ tran.f90 | 113 ++++++++++++----------------------------------- 2 files changed, 37 insertions(+), 113 deletions(-) diff --git a/perturbation.f90 b/perturbation.f90 index ad0f38a..be212f8 100644 --- a/perturbation.f90 +++ b/perturbation.f90 @@ -16041,23 +16041,12 @@ subroutine PTcontracted_matelem_class(jrot) ! Prepare the checkpoint file ! job_is ='external field contracted matrix elements for J=0' - if (trim(job%kinetmat_format).eq.'MPIIO') then - call openFile(extFmatHandler, job%extFmat_file, err, action='write', & - form='unformatted',position='rewind',status='replace') - HANDLE_ERROR(err) + call openFile(extFmatHandler, job%extFmat_file, err, action='write', & + form='unformatted',position='rewind',status='replace') + HANDLE_ERROR(err) - call extFmatHandler%write('Start external field') - call extFmatHandler%write(PT%Maxcontracts) - else - call IOStart(trim(job_is),chkptIO) - ! - open(chkptIO,form='unformatted',action='write',position='rewind',status='replace',file=job%extFmat_file) - write(chkptIO) 'Start external field' - ! - ! store the matrix elements - ! - write(chkptIO) PT%Maxcontracts - endif + call extFmatHandler%write('Start external field') + call extFmatHandler%write(PT%Maxcontracts) ! endif ! @@ -16109,14 +16098,8 @@ subroutine PTcontracted_matelem_class(jrot) ! ! always store the matrix elements of the extF moment ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - call extFmatHandler%write(imu) - call extFmatHandler%write(extF_t, mdimen) - else - write(chkptIO) imu - ! - write(chkptIO) extF_t - endif + call extFmatHandler%write(imu) + call extFmatHandler%write(extF_t, mdimen) ! endif ! @@ -16159,11 +16142,7 @@ subroutine PTcontracted_matelem_class(jrot) ! endif ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - if (.not.job%IOextF_divide) call extFmatHandler%write('End external field') - else - if (.not.job%IOextF_divide) write(chkptIO) 'End external field' - endif + if (.not.job%IOextF_divide) call extFmatHandler%write('End external field') ! endif ! diff --git a/tran.f90 b/tran.f90 index c5268d4..9cd5572 100644 --- a/tran.f90 +++ b/tran.f90 @@ -1858,41 +1858,22 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! filename = job%extFmat_file ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - ! - call openFile(extFmatHandler, filename, err, action='read', & - form='unformatted',position='rewind',status='old') - HANDLE_ERROR(err) - - call extFmatHandler%read(buf20(1:20)) - if (buf20/='Start external field') then - write (out,"(' restore_vib_matrix_elements ',a,' has bogus header: ',a)") filename,buf20 - stop 'restore_vib_matrix_elements - bogus file format' - end if + call openFile(extFmatHandler, filename, err, action='read', & + form='unformatted',position='rewind',status='old') + HANDLE_ERROR(err) - call extFmatHandler%read(ncontr_t) - if (bset_contr(1)%Maxcontracts/=ncontr_t) then - write (out,"(' Dipole moment checkpoint file ',a)") filename - write (out,"(' Actual and stored basis sizes at J=0 do not agree ',2i8)") bset_contr(1)%Maxcontracts,ncontr_t - stop 'restore_Extvib_matrix_elements - in file - illegal ncontracts ' - end if - else - open(iunit,form='unformatted',action='read',position='rewind',status='old',file=filename) - ! - read(iunit) buf20 - if (buf20/='Start external field') then - write (out,"(' restore_vib_matrix_elements ',a,' has bogus header: ',a)") filename,buf20 - stop 'restore_vib_matrix_elements - bogus file format' - end if - ! - read(iunit) ncontr_t - if (bset_contr(1)%Maxcontracts/=ncontr_t) then - write (out,"(' Dipole moment checkpoint file ',a)") filename - write (out,"(' Actual and stored basis sizes at J=0 do not agree ',2i8)") bset_contr(1)%Maxcontracts,ncontr_t - stop 'restore_Extvib_matrix_elements - in file - illegal ncontracts ' - end if - ! - endif + call extFmatHandler%read(buf20(1:20)) + if (buf20/='Start external field') then + write (out,"(' restore_vib_matrix_elements ',a,' has bogus header: ',a)") filename,buf20 + stop 'restore_vib_matrix_elements - bogus file format' + end if + + call extFmatHandler%read(ncontr_t) + if (bset_contr(1)%Maxcontracts/=ncontr_t) then + write (out,"(' Dipole moment checkpoint file ',a)") filename + write (out,"(' Actual and stored basis sizes at J=0 do not agree ',2i8)") bset_contr(1)%Maxcontracts,ncontr_t + stop 'restore_Extvib_matrix_elements - in file - illegal ncontracts ' + end if ! endif ! @@ -1903,25 +1884,15 @@ subroutine TRconvert_matel_j0_eigen(jrot) job_is ='external field contracted matrix elements for J=0' call IOStart(trim(job_is),chkptIO) ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - call openFile(exteigenHandler, job%exteigen_file, err, action='write', & - form='unformatted',position='rewind',status='replace') - HANDLE_ERROR(err) - call exteigenHandler%write('Start external field') - call exteigenHandler%write(neigenroots) - else - ! - open(chkptio,form='unformatted',action='write',position='rewind',status='replace',file=job%exteigen_file) - write(chkptio) 'Start external field' - ! - ! store the matrix elements - ! - write(chkptio) neigenroots - endif + call openFile(exteigenHandler, job%exteigen_file, err, action='write', & + form='unformatted',position='rewind',status='replace') + HANDLE_ERROR(err) + call exteigenHandler%write('Start external field') + call exteigenHandler%write(neigenroots) ! endif ! - if (trim(job%kinetmat_format).ne.'MPIIO'.and.job%IOextF_divide) close(iunit) + if (job%IOextF_divide) deallocate(exteigenHandler) ! rootsize = int(ncontr_t*(ncontr_t+1)/2,hik) rootsize2= int(ncontr_t*ncontr_t,hik) @@ -1960,14 +1931,8 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! else ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - call extFmatHandler%read(imu_t) - call extFmatHandler%read(extF_me) - else - read(iunit) imu_t - ! - read(iunit) extF_me - endif + call extFmatHandler%read(imu_t) + call extFmatHandler%read(extF_me) ! endif ! @@ -2028,12 +1993,8 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! if (.not.job%IOextF_divide.or.job%IOextF_stitch) then ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - call exteigenHandler%write(mat_s) - else - write(chkptIO) imu - write(chkptIO) mat_s - endif + call exteigenHandler%write(imu) + call exteigenHandler%write(mat_s) ! else ! @@ -2063,37 +2024,21 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! if (.not.job%IOextF_divide) then ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - call extFmatHandler%read(buf20(1:18)) - else - read(iunit) buf20(1:18) - endif + call extFmatHandler%read(buf20(1:18)) ! if (buf20(1:18)/='End external field') then write (out,"(' restore_Extvib_matrix_elements ',a,' has bogus footer: ',a)") filename,buf20(1:18) stop 'restore_Extvib_matrix_elements - bogus file format' end if ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - deallocate(extFmatHandler) - else - close(iunit,status='keep') - endif - ! - !job_is ='external field contracted matrix elements for J=0' - !call IOStart(trim(job_is),iunit) + deallocate(extFmatHandler) ! endif ! if (.not.job%IOextF_divide.or.job%IOextF_stitch) then ! - if (trim(job%kinetmat_format).eq.'MPIIO') then - call exteigenHandler%write('End external field') - deallocate(exteigenHandler) - else - write(chkptIO) 'End external field' - close(chkptIO,status='keep') - endif + call exteigenHandler%write('End external field') + deallocate(exteigenHandler) ! endif ! From 0d9517457342af6cc89410864c89c57ccad7e112 Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Mon, 22 Nov 2021 11:51:00 +0000 Subject: [PATCH 65/66] Remove some unused MPIIO sections --- tran.f90 | 28 ---------------------------- 1 file changed, 28 deletions(-) diff --git a/tran.f90 b/tran.f90 index 9cd5572..87f3215 100644 --- a/tran.f90 +++ b/tran.f90 @@ -1324,8 +1324,6 @@ subroutine TRconvert_matel_j0_eigen(jrot) integer(ik),allocatable :: ijterm(:,:) double precision,parameter :: alpha = 1.0d0,beta=0.0d0 character(len=cl) :: jchar,filename - type(MPI_File) :: fileh, fileh_w - integer(kind=MPI_OFFSET_KIND) :: mpioffset,read_offset,write_offset integer :: ierr class(ioHandlerBase), allocatable :: kineteigenHandler class(ioHandlerBase), allocatable :: kinetmatHandler @@ -1832,7 +1830,6 @@ subroutine TRconvert_matel_j0_eigen(jrot) ! ! External field part ! - ! TODO fix MPI here if (FLextF_matelem) then ! if (job%verbose>=3) write(out,"(/' Transform extF to J0-representation...')") @@ -1907,16 +1904,6 @@ subroutine TRconvert_matel_j0_eigen(jrot) call ArrayStart('extF_me',info,1,kind(extF_me),int(size(extF_me),hik)) endif ! - if ((.not.job%IOextF_divide) .and. blacs_size.gt.1) then -#ifdef TROVE_USE_MPI_ - call MPI_File_get_position(fileh, read_offset, ierr) - call MPI_File_set_view(fileh, read_offset, mpi_byte, extF_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 - ! do imu = fitting%iparam(1),fitting%iparam(2) ! if (job%verbose>=4) write(out,"(' imu = ',i8)",advance='NO') imu @@ -2003,21 +1990,6 @@ subroutine TRconvert_matel_j0_eigen(jrot) endif ! enddo - ! Reset view to flat file - if ((.not.job%IOextF_divide) .and. blacs_size.gt.1) then -#ifdef TROVE_USE_MPI_ - read_offset = read_offset + (fitting%iparam(2)-fitting%iparam(1)+1)*int(ncontr_t,MPI_OFFSET_KIND)*ncontr_t*mpi_real_size & - + (fitting%iparam(2)-fitting%iparam(1)+1)*mpi_int_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, 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 ! if (allocated(extF_me)) deallocate(extF_me) call ArrayStop('extF_me') From 0aaa8cfd148519433470b2900c854d3629a9589f Mon Sep 17 00:00:00 2001 From: Jamie Quinn Date: Tue, 18 Jan 2022 10:35:28 +0000 Subject: [PATCH 66/66] Fix bug in reading extfield.chk --- tran.f90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/tran.f90 b/tran.f90 index 87f3215..d61f630 100644 --- a/tran.f90 +++ b/tran.f90 @@ -1919,7 +1919,7 @@ subroutine TRconvert_matel_j0_eigen(jrot) else ! call extFmatHandler%read(imu_t) - call extFmatHandler%read(extF_me) + call extFmatHandler%read(extF_me, desc_extF, extF_block_type) ! endif ! @@ -1981,7 +1981,7 @@ subroutine TRconvert_matel_j0_eigen(jrot) if (.not.job%IOextF_divide.or.job%IOextF_stitch) then ! call exteigenHandler%write(imu) - call exteigenHandler%write(mat_s) + call exteigenHandler%write(mat_s, desc_mat_s, mat_s_block_type) ! else !