diff --git a/src/config/makefile.h b/src/config/makefile.h index 58a5a52ff6..930d7c55f4 100644 --- a/src/config/makefile.h +++ b/src/config/makefile.h @@ -3096,9 +3096,11 @@ ifneq ($(TARGET),LINUX) # Jeff: FreeBSD does not link libm automatically with flang ifeq ($(USE_FLANG),1) EXTRA_LIBS += -lm + DEFINES += -DUSE_FLANG endif endif + endif #endof of LINUX64 diff --git a/src/hessian/analytic/oned_calc.F b/src/hessian/analytic/oned_calc.F index d4498cfe29..e15de9e7bf 100644 --- a/src/hessian/analytic/oned_calc.F +++ b/src/hessian/analytic/oned_calc.F @@ -33,6 +33,9 @@ subroutine oned_calc(nxyz,g_rhs,Ibuf,lbuf,Iscr,lscr, logical status double precision qfac c + integer g_lo(3),g_hi(3),icadd + logical oned_getlohi + external oned_getlohi integer nxtask external nxtask cc AJL/Begin/SPIN ECPs @@ -42,14 +45,20 @@ subroutine oned_calc(nxyz,g_rhs,Ibuf,lbuf,Iscr,lscr, nproc = ga_nnodes() task_size = 1 ijatom = -1 - next = nxtask(nproc,task_size) +c next = nxtask(nproc,task_size) + call nga_distribution(g_rhs, + . ga_nodeid(), g_lo,g_hi) +c write(6,'(i4,"gadis",i4,3(i6,":",i6,","))') ga_nodeid(),g_rhs, +c . g_lo(1),g_hi(1), +c . g_lo(2),g_hi(2), +c . g_lo(3),g_hi(3) c do 90 iat1 = 1, nat do 80 iat2 = 1, nat c do 80 iat2 = 1, iat1 ijatom = ijatom + 1 - if ( ijatom .eq. next ) then +c if ( ijatom .eq. next ) then status = bas_ce2bfr(basis,iat1,iab1f,iab1l) status = bas_ce2bfr(basis,iat2,iab2f,iab2l) @@ -102,12 +111,26 @@ subroutine oned_calc(nxyz,g_rhs,Ibuf,lbuf,Iscr,lscr, c * idatom(2) c ic = 1 + icadd = 0 do i = 1, 2 do icart1 = 1, 3 lo(1) = (idatom(i)-1) * 3 + icart1 hi(1) = (idatom(i)-1) * 3 + icart1 cedo call nga_acc(g_rhs, lo, hi, Ibuf(ic), ld, 1.0d0) - call nga_put(g_rhs, lo, hi, Ibuf(ic), ld) +c check if I own this patch to do a local nga_put + if(oned_getlohi(g_lo,g_hi,ld, + c if1,if2, + c lo,hi, + c icadd)) then + +c write(6,'(i4,"gaput",i4,"icadd",i4, +c F 3(i6,":",i6,","))') ga_nodeid(),g_rhs, +c . icadd, +c . lo(1),hi(1), +c . lo(2),hi(2), +c . lo(3),hi(3) + call nga_put(g_rhs,lo,hi,Ibuf(ic+icadd),ld) + endif ic = ic + nint enddo enddo @@ -135,7 +158,12 @@ subroutine oned_calc(nxyz,g_rhs,Ibuf,lbuf,Iscr,lscr, lo(1) = atx hi(1) = atx ! call nga_acc(g_rhs, lo, hi, Ibuf(ic), ld, 1.0d0) - call nga_put(g_rhs, lo, hi, Ibuf(ic), ld) + if(oned_getlohi(g_lo,g_hi,ld, + c if1,if2, + c lo,hi, + c icadd)) then + call nga_put(g_rhs, lo, hi, Ibuf(ic+icadd), ld) + endif ic = ic + nint enddo endif ! doV and doT @@ -144,12 +172,44 @@ subroutine oned_calc(nxyz,g_rhs,Ibuf,lbuf,Iscr,lscr, 70 continue 1010 continue - next = nxtask(nproc,task_size) - endif ! if my task +c next = nxtask(nproc,task_size) +c endif ! if my task 80 continue 90 continue - next = nxtask(-nproc,task_size) +c next = nxtask(-nproc,task_size) + call ga_sync() +c call ga_print(g_rhs) c return end + logical function oned_getlohi(g_lo,g_hi,ld, + c if1,if2, + c lo,hi, + c icadd) + implicit none + integer g_lo(3),g_hi(3),ld(2) ! input + integer if1,if2 ! input + integer lo(3),hi(3) ! input/output + integer icadd ! output + oned_getlohi=.false. + icadd=0 + if((lo(1).ge.g_lo(1)).or.(hi(1).le.g_hi(1)).and. + I (lo(2).ge.g_lo(2)).or.(hi(2).le.g_hi(2)).and. + I (lo(3).ge.g_lo(3)).or.(hi(3).le.g_hi(3))) then + lo(1)=max(g_lo(1),lo(1)) + hi(1)=min(g_hi(1),hi(1)) + lo(2)=max(g_lo(2),lo(2)) + icadd=lo(2)-if2 + hi(2)=min(g_hi(2),hi(2)) + lo(3)=max(g_lo(3),lo(3)) + icadd=icadd+(lo(3)-if1)*ld(2) + hi(3)=min(g_hi(3),hi(3)) + if((hi(1).ge.lo(1)).and. + I (hi(2).ge.lo(2)).and. + I (hi(3).ge.lo(3))) then + oned_getlohi=.true. + endif + endif + return + end diff --git a/src/util/util_file_name.F b/src/util/util_file_name.F index e803a00b93..e1271a8d48 100644 --- a/src/util/util_file_name.F +++ b/src/util/util_file_name.F @@ -816,7 +816,7 @@ double precision function util_scratch_dir_avail_for_me() character*(nw_max_path_len) mine integer nuse integer avail0,avail1 - integer fd + integer fd,fd_in character*8 fstype integer l1megabyte,i_k,l_k,nuse_fail,nattpt, , availmax @@ -847,11 +847,14 @@ double precision function util_scratch_dir_avail_for_me() #else call util_getppn(ppn) io_node=mod(me,ppn).eq.0 + call ga_sync() if(io_node) then call util_file_name('junk',.true.,.true.,mine) ierr=eaf_delete(mine) ierr=eaf_open(mine, eaf_rw, fd) + call util_fsync(mine) ierr = eaf_stat(mine, avail0, fstype) +c write(6,*) ga_nodeid(), 'avail0 ',avail0 if(avail0.gt.fiftytb) toolarge=1 else ierr=0 @@ -881,7 +884,9 @@ double precision function util_scratch_dir_avail_for_me() call ga_sync() nuse_fail=0 if(io_node) then + call util_fsync(mine) ierr = eaf_stat(mine, avail1, fstype) +c write(6,*) ga_nodeid(), 'avail1 ',avail1 if (ierr .ne. 0) call errquit( U 'util_scratch_avail: eaf_stat',ierr,DISK_ERR) ierr=eaf_delete(mine) @@ -1161,3 +1166,31 @@ subroutine cphf_fname_parallel(cphf_str1,cphf_str2) A cphf_str2(1:inp_strlen(cphf_str2)) return end + subroutine util_fsync(fname) + implicit none + character*(*),intent(in) :: fname +c + integer iunit + integer*4 fd_in,code + integer ga_nodeid + external ga_nodeid +c + interface + function fsync (fd) bind(c,name="fsync") + use iso_c_binding, only: c_int + integer(c_int), value :: fd + integer(c_int) :: fsync + end function fsync + end interface + iunit=10 + open (iunit,file=fname) + call util_flush(iunit) +#if defined(GFORTRAN) && !defined(USE_FLANG) && !defined(__llvm__) && !defined(___PGLLVM__) + fd_in=fnum(iunit) +c Flush and sync + code=fsync(fd_in) + if(code.ne.0) call + c errquit("Error calling FSYNC",ga_nodeid(),0) +#endif + return + end