From 5b6ecfa564b8d889981342c2e9ad597d124d15a3 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 17 Apr 2023 17:03:16 +0200 Subject: [PATCH] Improve thread-safety --- src/cipsi/environment.irp.f | 2 ++ src/davidson/davidson_parallel.irp.f | 4 ++++ src/ezfio_files/lock.irp.f | 17 +++++++++++++++++ src/mo_two_e_ints/map_integrals.irp.f | 2 ++ src/nuclei/nuclei.irp.f | 14 +++++++------- src/two_body_rdm/io_two_rdm.irp.f | 12 ++++++++---- src/utils/format_w_error.irp.f | 4 ++-- src/utils/memory.irp.f | 8 ++++++-- 8 files changed, 48 insertions(+), 15 deletions(-) diff --git a/src/cipsi/environment.irp.f b/src/cipsi/environment.irp.f index 5c0e0820..363b8f1c 100644 --- a/src/cipsi/environment.irp.f +++ b/src/cipsi/environment.irp.f @@ -7,7 +7,9 @@ BEGIN_PROVIDER [ integer, nthreads_pt2 ] character*(32) :: env call getenv('QP_NTHREADS_PT2',env) if (trim(env) /= '') then + call lock_io() read(env,*) nthreads_pt2 + call unlock_io() call write_int(6,nthreads_pt2,'Target number of threads for PT2') endif END_PROVIDER diff --git a/src/davidson/davidson_parallel.irp.f b/src/davidson/davidson_parallel.irp.f index e627dfc9..399ab11b 100644 --- a/src/davidson/davidson_parallel.irp.f +++ b/src/davidson/davidson_parallel.irp.f @@ -150,7 +150,9 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze, exit endif if(task_id == 0) exit + call lock_io() read (msg,*) imin, imax, ishift, istep + call unlock_io() integer :: k do k=imin,imax v_t(:,k) = 0.d0 @@ -555,7 +557,9 @@ BEGIN_PROVIDER [ integer, nthreads_davidson ] character*(32) :: env call getenv('QP_NTHREADS_DAVIDSON',env) if (trim(env) /= '') then + call lock_io() read(env,*) nthreads_davidson + call unlock_io() call write_int(6,nthreads_davidson,'Target number of threads for ') endif END_PROVIDER diff --git a/src/ezfio_files/lock.irp.f b/src/ezfio_files/lock.irp.f index 53a99254..d28f7641 100644 --- a/src/ezfio_files/lock.irp.f +++ b/src/ezfio_files/lock.irp.f @@ -9,4 +9,21 @@ BEGIN_PROVIDER [ integer(omp_lock_kind), file_lock ] call omp_init_lock(file_lock) END_PROVIDER +! These functions need to be called because internal read and write are not thread safe. +subroutine lock_io() + implicit none + BEGIN_DOC +! Needs to be called because before doing I/O because internal read and write +! are not thread safe. + END_DOC + call omp_set_lock(file_lock) +end subroutine lock_io() +subroutine unlock_io() + implicit none + BEGIN_DOC +! Needs to be called because afterdoing I/O because internal read and write +! are not thread safe. + END_DOC + call omp_unset_lock(file_lock) +end subroutine lock_io() diff --git a/src/mo_two_e_ints/map_integrals.irp.f b/src/mo_two_e_ints/map_integrals.irp.f index 272916e3..ada256a2 100644 --- a/src/mo_two_e_ints/map_integrals.irp.f +++ b/src/mo_two_e_ints/map_integrals.irp.f @@ -377,6 +377,7 @@ integer function load_mo_integrals(filename) integer*8 :: n, j load_mo_integrals = 1 open(unit=66,file=filename,FORM='unformatted',STATUS='UNKNOWN') + call lock_io() read(66,err=98,end=98) iknd, kknd if (iknd /= integral_kind) then print *, 'Wrong integrals kind in file :', iknd @@ -399,6 +400,7 @@ integer function load_mo_integrals(filename) n = mo_integrals_map%map(i)%n_elements read(66,err=99,end=99) (key(j), j=1,n), (val(j), j=1,n) enddo + call unlock_io() call map_sort(mo_integrals_map) load_mo_integrals = 0 return diff --git a/src/nuclei/nuclei.irp.f b/src/nuclei/nuclei.irp.f index 3c04316f..fabdc42e 100644 --- a/src/nuclei/nuclei.irp.f +++ b/src/nuclei/nuclei.irp.f @@ -241,13 +241,13 @@ END_PROVIDER enddo character*(80) :: buffer, dummy do - read(iunit,'(A80)',end=10) buffer - read(buffer,*) i ! First read i - read(buffer,*) i, element_name(i), dummy, element_mass(i) - enddo - 10 continue - close(10) - endif + read(iunit,'(A80)',end=10) buffer + read(buffer,*) i ! First read i + read(buffer,*) i, element_name(i), dummy, element_mass(i) + enddo + 10 continue + close(10) + endif IRP_IF MPI_DEBUG print *, irp_here, mpi_rank diff --git a/src/two_body_rdm/io_two_rdm.irp.f b/src/two_body_rdm/io_two_rdm.irp.f index f7008ca9..bdd8a4f9 100644 --- a/src/two_body_rdm/io_two_rdm.irp.f +++ b/src/two_body_rdm/io_two_rdm.irp.f @@ -1,15 +1,17 @@ subroutine write_array_two_rdm(n_orb,nstates,array_tmp,name_file) implicit none integer, intent(in) :: n_orb,nstates - character*(128), intent(in) :: name_file + character*(128), intent(in) :: name_file double precision, intent(in) :: array_tmp(n_orb,n_orb,n_orb,n_orb,nstates) character*(128) :: output integer :: i_unit_output,getUnitAndOpen - PROVIDE ezfio_filename + PROVIDE ezfio_filename output=trim(ezfio_filename)//'/work/'//trim(name_file) i_unit_output = getUnitAndOpen(output,'W') + call lock_io() write(i_unit_output)array_tmp + call unlock_io() close(unit=i_unit_output) end @@ -18,12 +20,14 @@ subroutine read_array_two_rdm(n_orb,nstates,array_tmp,name_file) character*(128) :: output integer :: i_unit_output,getUnitAndOpen integer, intent(in) :: n_orb,nstates - character*(128), intent(in) :: name_file + character*(128), intent(in) :: name_file double precision, intent(out) :: array_tmp(n_orb,n_orb,n_orb,n_orb,N_states) - PROVIDE ezfio_filename + PROVIDE ezfio_filename output=trim(ezfio_filename)//'/work/'//trim(name_file) i_unit_output = getUnitAndOpen(output,'R') + call lock_io() read(i_unit_output)array_tmp + call unlock_io() close(unit=i_unit_output) end diff --git a/src/utils/format_w_error.irp.f b/src/utils/format_w_error.irp.f index ce2665a7..7f7458b6 100644 --- a/src/utils/format_w_error.irp.f +++ b/src/utils/format_w_error.irp.f @@ -33,7 +33,7 @@ subroutine format_w_error(value,error,size_nb,max_nb_digits,format_value,str_err character(len=20) :: str_size, str_nb_digits, str_exp integer :: nb_digits - !$OMP CRITICAL + call lock_io() ! max_nb_digit: Y max ! size_nb = Size of the double: X (FX.Y) write(str_size,'(I3)') size_nb @@ -68,6 +68,6 @@ subroutine format_w_error(value,error,size_nb,max_nb_digits,format_value,str_err ! FX.Y just for the value format_value = 'F'//trim(adjustl(str_size))//'.'//trim(adjustl(str_nb_digits)) - !$OMP END CRITICAL + call unlock_io() end diff --git a/src/utils/memory.irp.f b/src/utils/memory.irp.f index d5a066a1..115b2cbe 100644 --- a/src/utils/memory.irp.f +++ b/src/utils/memory.irp.f @@ -8,7 +8,9 @@ BEGIN_PROVIDER [ integer, qp_max_mem ] qp_max_mem = 2000 call getenv('QP_MAXMEM',env) if (trim(env) /= '') then + call lock_io() read(env,*) qp_max_mem + call unlock_io() endif call write_int(6,qp_max_mem,'Target maximum memory (GB)') @@ -25,7 +27,7 @@ subroutine resident_memory(value) character*(32) :: key double precision, intent(out) :: value - call omp_set_lock(file_lock) + call lock_io() call usleep(10) value = 0.d0 @@ -40,7 +42,7 @@ subroutine resident_memory(value) 20 continue close(iunit) value = value / (1024.d0*1024.d0) - call omp_unset_lock(file_lock) + call unlock_io() end function subroutine total_memory(value) @@ -53,6 +55,7 @@ subroutine total_memory(value) character*(32) :: key double precision, intent(out) :: value + call lock_io() iunit = getUnitAndOpen('/proc/self/status','r') do read(iunit,*,err=10,end=20) key, value @@ -64,6 +67,7 @@ subroutine total_memory(value) 20 continue close(iunit) value = value / (1024.d0*1024.d0) + call unlock_io() end function double precision function memory_of_double(n)