Commit e23d27a0 authored by Victor Yu's avatar Victor Yu

Fix non-standard Fortran code

* Optional arguments in apply_operator were made non-optional, as
  optional arguments without explicit interface are disallowed. Those
  optional arguments were almost always supplied anyway when calling
  apply_operator. Without this fix, code could not work properly with
  pgfortran and nvfortran.

* Argument list was incorrect when calling get_brak_hyper_parallel.
  Again, this works with some compilers because of the memory layout
  but it doesn't work with pgfortran.
parent 83340393
......@@ -266,7 +266,7 @@ SUBROUTINE solve_gfreq_gamma(l_read_restart)
CALL solve_deflated_lanczos_w_full_ortho ( nbnd, pert%nloc, n_lanczos, dvpsi, diago, subdiago, q_s, bnorm)
!
ALLOCATE( braket ( pert%nglob, n_lanczos , pert%nloc ) )
CALL get_brak_hyper_parallel(dvpsi,pert%nloc,n_lanczos,q_s,braket,pert%nloc,pert%nlocx,pert%nglob)
CALL get_brak_hyper_parallel(dvpsi,pert%nloc,n_lanczos,q_s,braket,pert)
DEALLOCATE( q_s )
!
DO ip = 1, pert%nloc
......@@ -607,7 +607,7 @@ SUBROUTINE solve_gfreq_k(l_read_restart)
CALL solve_deflated_lanczos_w_full_ortho ( nbnd, pert%nloc, n_lanczos, dvpsi, diago, subdiago, q_s, bnorm)
!
ALLOCATE( braket ( pert%nglob, n_lanczos , pert%nloc ) )
CALL get_brak_hyper_parallel_complex(dvpsi,pert%nloc,n_lanczos,q_s,braket,pert%nloc,pert%nlocx,pert%nglob)
CALL get_brak_hyper_parallel_complex(dvpsi,pert%nloc,n_lanczos,q_s,braket,pert)
DEALLOCATE( q_s )
!
DO ip = 1, pert%nloc
......
......@@ -450,7 +450,7 @@ SUBROUTINE solve_wfreq_gamma(l_read_restart,l_generate_plot)
CALL solve_deflated_lanczos_w_full_ortho ( nbnd, mypara%nloc, n_lanczos, dvpsi, diago, subdiago, q_s, bnorm)
!
ALLOCATE( braket ( mypara%nglob, n_lanczos , mypara%nloc ) )
CALL get_brak_hyper_parallel(dvpsi,mypara%nloc,n_lanczos,q_s,braket,mypara%nloc,mypara%nlocx,mypara%nglob)
CALL get_brak_hyper_parallel(dvpsi,mypara%nloc,n_lanczos,q_s,braket,mypara)
DEALLOCATE( q_s )
!
DO ip = 1, mypara%nloc
......@@ -1105,7 +1105,7 @@ SUBROUTINE solve_wfreq_k(l_read_restart,l_generate_plot)
CALL solve_deflated_lanczos_w_full_ortho ( nbnd, mypara%nloc, n_lanczos, dvpsi, diago, subdiago, q_s, bnorm)
!
ALLOCATE( braket ( mypara%nglob, n_lanczos , mypara%nloc ) )
CALL get_brak_hyper_parallel_complex(dvpsi,mypara%nloc,n_lanczos,q_s,braket,mypara%nloc,mypara%nlocx,mypara%nglob)
CALL get_brak_hyper_parallel_complex(dvpsi,mypara%nloc,n_lanczos,q_s,braket,mypara)
DEALLOCATE( q_s )
!
DO ip = 1, mypara%nloc
......
!
! Copyright (C) 2015-2017 M. Govoni
! Copyright (C) 2015-2017 M. Govoni
! This file is distributed under the terms of the
! GNU General Public License. See the file `License'
! in the root directory of the present distribution,
......@@ -7,7 +7,7 @@
!
! This file is part of WEST.
!
! Contributors to this file:
! Contributors to this file:
! Marco Govoni
!
!-------------------------------------------------------------------------
......@@ -28,15 +28,12 @@ SUBROUTINE apply_operator (m,dvg,dng,tr2,iq)
INTEGER, INTENT(IN) :: m
COMPLEX(DP), INTENT(IN) :: dvg(npwqx,m)
COMPLEX(DP), INTENT(OUT) :: dng(npwqx,m)
REAL(DP),INTENT(IN), OPTIONAL :: tr2
INTEGER, INTENT(IN), OPTIONAL :: iq
REAL(DP),INTENT(IN) :: tr2
INTEGER, INTENT(IN) :: iq
!
! Workspace
!
INTEGER :: ipert, ig, i
INTEGER :: iq_
!
REAL(DP) :: tr2_
!
COMPLEX(DP), ALLOCATABLE ::aux_g(:,:)
!
......@@ -45,42 +42,31 @@ SUBROUTINE apply_operator (m,dvg,dng,tr2,iq)
CALL mp_barrier( world_comm )
!
l_outsource = .FALSE.
DO i = 1,2
DO i = 1,2
IF( wstat_calculation(i:i) == 'E' ) l_outsource = .TRUE.
ENDDO
!
IF(PRESENT(iq)) THEN
iq_ = iq
ELSE
iq_ = 1
ENDIF
IF(PRESENT(tr2)) THEN
tr2_ = tr2
ELSE
tr2_ = 1.d-8
ENDIF
!
dng=0._DP
!
ALLOCATE( aux_g(npwqx,m) ); aux_g=0._DP
!
DO ipert = 1, m
DO ig = 1, npwq
aux_g(ig,ipert) = dvg(ig,ipert) * pot3D%sqvc(ig) ! perturbation acts only on body
aux_g(ig,ipert) = dvg(ig,ipert) * pot3D%sqvc(ig) ! perturbation acts only on body
ENDDO
ENDDO
!
IF( l_outsource ) THEN
CALL calc_outsourced(m,aux_g,dng,iq_)
CALL calc_outsourced(m,aux_g,dng,iq)
ELSE
CALL dfpt(m,aux_g,dng,tr2_,iq_)
CALL dfpt(m,aux_g,dng,tr2,iq)
ENDIF
!
DEALLOCATE( aux_g )
DEALLOCATE( aux_g )
!
DO ipert = 1, m
DO ig = 1, npwq
dng(ig,ipert) = dng(ig,ipert) * pot3D%sqvc(ig) ! perturbation acts only on body
dng(ig,ipert) = dng(ig,ipert) * pot3D%sqvc(ig) ! perturbation acts only on body
ENDDO
ENDDO
!
......@@ -95,11 +81,11 @@ SUBROUTINE calc_outsourced (m,dvg,dng,iq)
!
USE kinds, ONLY : DP
USE mp, ONLY : mp_barrier
USE westcom, ONLY : npwq,npwqx,fftdriver,igq_q
USE mp_global, ONLY : intra_image_comm,inter_pool_comm,my_image_id,me_bgrp
USE westcom, ONLY : npwq,npwqx,fftdriver,igq_q
USE mp_global, ONLY : intra_image_comm,my_image_id,me_bgrp
USE fft_at_k, ONLY : single_fwfft_k,single_invfft_k
USE fft_at_gamma, ONLY : single_fwfft_gamma,single_invfft_gamma,double_fwfft_gamma,double_invfft_gamma
USE fft_base, ONLY : dfftp,dffts
USE fft_at_gamma, ONLY : single_fwfft_gamma,single_invfft_gamma
USE fft_base, ONLY : dffts
USE control_flags, ONLY : gamma_only
USE function3d, ONLY : write_function3d,read_function3d
USE conversions, ONLY : itoa
......@@ -119,7 +105,7 @@ SUBROUTINE calc_outsourced (m,dvg,dng,iq)
CHARACTER(LEN=:),ALLOCATABLE :: filename
CHARACTER(LEN=:),ALLOCATABLE :: lockfile
!
INTEGER :: ipert, iu, stat
INTEGER :: ipert, iu, stat
TYPE(bar_type) :: barra
!
IF(iq/=1) CALL errore("outsourced","iq /= 1 not allowed",iq)
......@@ -128,7 +114,7 @@ SUBROUTINE calc_outsourced (m,dvg,dng,iq)
!
CALL start_bar_type( barra, 'outsourced', MAX(m,1) )
!
IF (m>0) THEN
IF (m>0) THEN
!
ALLOCATE(aux_r(dffts%nnr)); aux_r=0._DP
ALLOCATE(aux_r_double(dffts%nnr)); aux_r=0._DP
......@@ -144,23 +130,23 @@ SUBROUTINE calc_outsourced (m,dvg,dng,iq)
ENDIF
!
filename = "I."//itoa(my_image_id)//"_P."//itoa(ipert)//".xml"
aux_r_double(:) = DBLE(aux_r(:)) / 2._DP ! The output must be in Ha Atomic units
aux_r_double(:) = DBLE(aux_r(:)) / 2._DP ! The output must be in Ha Atomic units
CALL write_function3d(filename,aux_r_double,dffts)
!
ENDDO
!
! DUMP A LOCK FILE
! DUMP A LOCK FILE
!
IF( me_bgrp == 0 ) THEN
IF( me_bgrp == 0 ) THEN
lockfile = "I."//itoa(my_image_id)//".lock"
OPEN(NEWUNIT=iu,FILE=lockfile)
DO ipert = 1, m
OPEN(NEWUNIT=iu,FILE=lockfile)
DO ipert = 1, m
filename = "I."//itoa(my_image_id)//"_P."//itoa(ipert)//".xml"
WRITE(iu,'(A)') filename
ENDDO
CLOSE(iu)
!
! SLEEP AND WAIT FOR LOCKFILE TO BE REMOVED
! SLEEP AND WAIT FOR LOCKFILE TO BE REMOVED
!
CALL sleep_and_wait_for_lock_to_be_removed(lockfile)
!
......@@ -174,8 +160,8 @@ SUBROUTINE calc_outsourced (m,dvg,dng,iq)
!
filename = "I."//itoa(my_image_id)//"_P."//itoa(ipert)//".xml.response"
CALL read_function3d(filename,aux_r_double,dffts)
aux_r(:) = CMPLX(aux_r_double(:),0._DP)
!
aux_r(:) = CMPLX(aux_r_double(:),0._DP)
!
IF(gamma_only) THEN
CALL single_fwfft_gamma(dffts,npwq,npwqx,aux_r,dng(:,ipert),TRIM(fftdriver))
ELSE
......@@ -186,9 +172,9 @@ SUBROUTINE calc_outsourced (m,dvg,dng,iq)
!
! CLEANUP
!
IF( me_bgrp == 0 ) THEN
IF( me_bgrp == 0 ) THEN
DO ipert = 1, m
filename = "I."//itoa(my_image_id)//"_P."//itoa(ipert)//".xml"
filename = "I."//itoa(my_image_id)//"_P."//itoa(ipert)//".xml"
OPEN(NEWUNIT=iu, IOSTAT=stat, FILE=filename, STATUS='OLD')
IF (stat == 0) CLOSE(iu, STATUS='DELETE')
filename = "I."//itoa(my_image_id)//"_P."//itoa(ipert)//".xml.response"
......@@ -196,12 +182,12 @@ SUBROUTINE calc_outsourced (m,dvg,dng,iq)
IF (stat == 0) CLOSE(iu, STATUS='DELETE')
ENDDO
ENDIF
CALL update_bar_type( barra, 'outsourced', m )
CALL update_bar_type( barra, 'outsourced', m )
DEALLOCATE(aux_r)
DEALLOCATE(aux_r_double)
ELSE
ELSE
CALL update_bar_type( barra, 'outsourced', 1 )
ENDIF
ENDIF
CALL stop_bar_type( barra, 'outsourced' )
!
!
......@@ -211,12 +197,10 @@ END SUBROUTINE
SUBROUTINE sleep_and_wait_for_lock_to_be_removed(lockfile)
!
USE westcom, ONLY: document
USE forpy_mod, ONLY: call_py, call_py_noret, import_py, module_py
USE forpy_mod, ONLY: tuple, tuple_create
USE forpy_mod, ONLY: dict, dict_create
USE forpy_mod, ONLY: list, list_create
USE forpy_mod, ONLY: call_py, import_py, module_py
USE forpy_mod, ONLY: tuple, tuple_create
USE forpy_mod, ONLY: dict, dict_create
USE forpy_mod, ONLY: object, cast
USE forpy_mod, ONLY: exception_matches, KeyError, err_clear, err_print
!
IMPLICIT NONE
!
......@@ -230,7 +214,7 @@ SUBROUTINE sleep_and_wait_for_lock_to_be_removed(lockfile)
INTEGER :: return_int
!
IERR = import_py(pymod, "west_clientserver")
!
!
IERR = tuple_create(args, 1)
IERR = args%setitem(0, TRIM(ADJUSTL(lockfile)) )
IERR = dict_create(kwargs)
......@@ -245,6 +229,6 @@ SUBROUTINE sleep_and_wait_for_lock_to_be_removed(lockfile)
CALL kwargs%destroy
CALL args%destroy
CALL return_obj%destroy
CALL pymod%destroy
CALL pymod%destroy
!
END SUBROUTINE
......@@ -227,7 +227,7 @@ SUBROUTINE davidson_diago_gamma ( )
ENDDO
!
pccg_res_tr2 = MIN(0.01_DP,1000000._DP*tr2_dfpt)
CALL apply_operator ( mloc, dvg(1,mstart), dng(1,mstart), pccg_res_tr2 )
CALL apply_operator ( mloc, dvg(1,mstart), dng(1,mstart), pccg_res_tr2, 1 )
!
! </ EXTRA STEP >
!
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment