Merge pull request #273 from QuantumPackage/io

Improve thread-safety

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

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 <Psi|H|Psi>')
  endif
 END_PROVIDER

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()

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

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

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
 

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

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)