LCPQ/qp2
9
1
Fork 0
mirror of https://github.com/QuantumPackage/qp2.git synced 2024-12-21 11:03:29 +01:00
Code Releases Activity

Fix compilation with gfortran
Some checks failed
continuous-integration/drone/push Build is failing
Details

Browse Source
This commit is contained in:
Anthony Scemama 2022-11-01 10:21:36 +01:00
parent 71693637b6
commit d387ee549a
5 changed files with 39 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
src/dav_general_mat/dav_diag_dressed_ext_rout.irp.f
View File

@ -27,7 +27,7 @@ subroutine davidson_general_ext_rout_diag_dressed(u_in,H_jj,Dress_jj,energies,sz
double precision, intent(in) :: H_jj(sze),Dress_jj(sze) double precision, intent(in) :: H_jj(sze),Dress_jj(sze)
double precision, intent(inout) :: u_in(sze,N_st_diag_in) double precision, intent(inout) :: u_in(sze,N_st_diag_in)
double precision, intent(out) :: energies(N_st) double precision, intent(out) :: energies(N_st)
external hcalc external :: hcalc
integer :: iter, N_st_diag integer :: iter, N_st_diag
integer :: i,j,k,l,m integer :: i,j,k,l,m
@ -207,7 +207,7 @@ subroutine davidson_general_ext_rout_diag_dressed(u_in,H_jj,Dress_jj,energies,sz
enddo enddo
! Normalize all states ! Normalize all states
do k=1,N_st_diag do k=1,N_st_diag
call normalize(u_in(1,k),sze) call normalize(u_in(:,k),sze)
enddo enddo
! Copy from the guess input "u_in" to the working vectors "U" ! Copy from the guess input "u_in" to the working vectors "U"
@ -238,10 +238,10 @@ subroutine davidson_general_ext_rout_diag_dressed(u_in,H_jj,Dress_jj,energies,sz
call ortho_qr(U,size(U,1),sze,shift2) call ortho_qr(U,size(U,1),sze,shift2)
! it does W = H U with W(sze,N_st_diag),U(sze,N_st_diag) ! it does W = H U with W(sze,N_st_diag),U(sze,N_st_diag)
! where sze is the size of the vector, N_st_diag is the number of states ! where sze is the size of the vector, N_st_diag is the number of states
call hcalc(W(1,shift+1),U(1,shift+1),N_st_diag,sze) call hcalc(W(:,shift+1),U(:,shift+1),N_st_diag,sze)
! Compute then the DIAGONAL PART OF THE DRESSING ! Compute then the DIAGONAL PART OF THE DRESSING
! <i|W_k> += Dress_jj(i) * <i|U> ! <i|W_k> += Dress_jj(i) * <i|U>
call dressing_diag_uv(W(1,shift+1),U(1,shift+1),Dress_jj,N_st_diag_in,sze) call dressing_diag_uv(W(:,shift+1),U(:,shift+1),Dress_jj,N_st_diag_in,sze)
else else
! Already computed in update below ! Already computed in update below
continue continue
@ -303,9 +303,9 @@ subroutine davidson_general_ext_rout_diag_dressed(u_in,H_jj,Dress_jj,energies,sz
! -------------------------------------------------- ! --------------------------------------------------
call dgemm('N','N', sze, N_st_diag, shift2, & call dgemm('N','N', sze, N_st_diag, shift2, &
1.d0, U, size(U,1), y, size(y,1), 0.d0, U(1,shift2+1), size(U,1)) 1.d0, U, size(U,1), y, size(y,1), 0.d0, U(:,shift2+1), size(U,1))
call dgemm('N','N', sze, N_st_diag, shift2, & call dgemm('N','N', sze, N_st_diag, shift2, &
1.d0, W, size(W,1), y, size(y,1), 0.d0, W(1,shift2+1), size(W,1)) 1.d0, W, size(W,1), y, size(y,1), 0.d0, W(:,shift2+1), size(W,1))
! Compute residual vector and davidson step ! Compute residual vector and davidson step
! ----------------------------------------- ! -----------------------------------------
@ -319,7 +319,7 @@ subroutine davidson_general_ext_rout_diag_dressed(u_in,H_jj,Dress_jj,energies,sz
enddo enddo
if (k <= N_st) then if (k <= N_st) then
residual_norm(k) = u_dot_u(U(1,shift2+k),sze) residual_norm(k) = u_dot_u(U(:,shift2+k),sze)
to_print(1,k) = lambda(k) to_print(1,k) = lambda(k)
to_print(2,k) = residual_norm(k) to_print(2,k) = residual_norm(k)
endif endif

23
src/dav_general_mat/dav_double_dress_ext_rout.irp.f
View File

@ -31,7 +31,8 @@ subroutine dav_double_dressed(u_in,H_jj,Dress_jj,Dressing_vec,idx_dress,energies
double precision, intent(inout) :: u_in(sze,N_st_diag) double precision, intent(inout) :: u_in(sze,N_st_diag)
double precision, intent(out) :: energies(N_st_diag) double precision, intent(out) :: energies(N_st_diag)
logical, intent(out) :: converged logical, intent(out) :: converged
external hcalc
external :: hcalc
double precision, allocatable :: H_jj_tmp(:) double precision, allocatable :: H_jj_tmp(:)
ASSERT (N_st > 0) ASSERT (N_st > 0)
@ -224,7 +225,7 @@ subroutine dav_double_dressed(u_in,H_jj,Dress_jj,Dressing_vec,idx_dress,energies
u_in(k,k) = u_in(k,k) + 10.d0 u_in(k,k) = u_in(k,k) + 10.d0
enddo enddo
do k=1,N_st_diag_in do k=1,N_st_diag_in
call normalize(u_in(1,k),sze) call normalize(u_in(:,k),sze)
enddo enddo
do k=1,N_st_diag_in do k=1,N_st_diag_in
@ -248,10 +249,10 @@ subroutine dav_double_dressed(u_in,H_jj,Dress_jj,Dressing_vec,idx_dress,energies
if ((iter > 1).or.(itertot == 1)) then if ((iter > 1).or.(itertot == 1)) then
! Compute |W_k> = \sum_i |i><i|H|u_k> ! Compute |W_k> = \sum_i |i><i|H|u_k>
! ----------------------------------- ! -----------------------------------
call hcalc(W(1,shift+1),U(1,shift+1),N_st_diag_in,sze) call hcalc(W(:,shift+1),U(:,shift+1),N_st_diag_in,sze)
! Compute then the DIAGONAL PART OF THE DRESSING ! Compute then the DIAGONAL PART OF THE DRESSING
! <i|W_k> += Dress_jj(i) * <i|U> ! <i|W_k> += Dress_jj(i) * <i|U>
call dressing_diag_uv(W(1,shift+1),U(1,shift+1),Dress_jj,N_st_diag_in,sze) call dressing_diag_uv(W(:,shift+1),U(:,shift+1),Dress_jj,N_st_diag_in,sze)
else else
! Already computed in update below ! Already computed in update below
continue continue
@ -275,20 +276,20 @@ subroutine dav_double_dressed(u_in,H_jj,Dress_jj,Dressing_vec,idx_dress,energies
! !
! call dgemm('T','N', N_st, N_st_diag_in, sze, 1.d0, & ! call dgemm('T','N', N_st, N_st_diag_in, sze, 1.d0, &
! psi_coef, size(psi_coef,1), & ! psi_coef, size(psi_coef,1), &
! U(1,shift+1), size(U,1), 0.d0, s_tmp, size(s_tmp,1)) ! U(:,shift+1), size(U,1), 0.d0, s_tmp, size(s_tmp,1))
! !
! call dgemm('N','N', sze, N_st_diag_in, N_st, 1.0d0, & ! call dgemm('N','N', sze, N_st_diag_in, N_st, 1.0d0, &
! Dressing_vec, size(Dressing_vec,1), s_tmp, size(s_tmp,1), & ! Dressing_vec, size(Dressing_vec,1), s_tmp, size(s_tmp,1), &
! 1.d0, W(1,shift+1), size(W,1)) ! 1.d0, W(:,shift+1), size(W,1))
! !
! !
! call dgemm('T','N', N_st, N_st_diag_in, sze, 1.d0, & ! call dgemm('T','N', N_st, N_st_diag_in, sze, 1.d0, &
! Dressing_vec, size(Dressing_vec,1), & ! Dressing_vec, size(Dressing_vec,1), &
! U(1,shift+1), size(U,1), 0.d0, s_tmp, size(s_tmp,1)) ! U(:,shift+1), size(U,1), 0.d0, s_tmp, size(s_tmp,1))
! !
! call dgemm('N','N', sze, N_st_diag_in, N_st, 1.0d0, & ! call dgemm('N','N', sze, N_st_diag_in, N_st, 1.0d0, &
! psi_coef, size(psi_coef,1), s_tmp, size(s_tmp,1), & ! psi_coef, size(psi_coef,1), s_tmp, size(s_tmp,1), &
! 1.d0, W(1,shift+1), size(W,1)) ! 1.d0, W(:,shift+1), size(W,1))
! !
endif endif
@ -376,9 +377,9 @@ subroutine dav_double_dressed(u_in,H_jj,Dress_jj,Dressing_vec,idx_dress,energies
! -------------------------------------------------- ! --------------------------------------------------
call dgemm('N','N', sze, N_st_diag_in, shift2, & call dgemm('N','N', sze, N_st_diag_in, shift2, &
1.d0, U, size(U,1), y, size(y,1), 0.d0, U(1,shift2+1), size(U,1)) 1.d0, U, size(U,1), y, size(y,1), 0.d0, U(:,shift2+1), size(U,1))
call dgemm('N','N', sze, N_st_diag_in, shift2, & call dgemm('N','N', sze, N_st_diag_in, shift2, &
1.d0, W, size(W,1), y, size(y,1), 0.d0, W(1,shift2+1), size(W,1)) 1.d0, W, size(W,1), y, size(y,1), 0.d0, W(:,shift2+1), size(W,1))
! Compute residual vector and davidson step ! Compute residual vector and davidson step
! ----------------------------------------- ! -----------------------------------------
@ -392,7 +393,7 @@ subroutine dav_double_dressed(u_in,H_jj,Dress_jj,Dressing_vec,idx_dress,energies
enddo enddo
if (k <= N_st) then if (k <= N_st) then
residual_norm(k) = u_dot_u(U(1,shift2+k),sze) residual_norm(k) = u_dot_u(U(:,shift2+k),sze)
to_print(1,k) = lambda(k) to_print(1,k) = lambda(k)
to_print(2,k) = residual_norm(k) to_print(2,k) = residual_norm(k)
endif endif

18
src/dav_general_mat/dav_dressed_ext_rout.irp.f
View File

@ -214,7 +214,7 @@ subroutine davidson_general_ext_rout_dressed(u_in,H_jj,energies,sze,N_st,N_st_di
enddo enddo
! Normalize all states ! Normalize all states
do k=1,N_st_diag do k=1,N_st_diag
call normalize(u_in(1,k),sze) call normalize(u_in(:,k),sze)
enddo enddo
! Copy from the guess input "u_in" to the working vectors "U" ! Copy from the guess input "u_in" to the working vectors "U"
@ -244,7 +244,7 @@ subroutine davidson_general_ext_rout_dressed(u_in,H_jj,energies,sze,N_st,N_st_di
call ortho_qr(U,size(U,1),sze,shift2) call ortho_qr(U,size(U,1),sze,shift2)
! it does W = H U with W(sze,N_st_diag),U(sze,N_st_diag) ! it does W = H U with W(sze,N_st_diag),U(sze,N_st_diag)
! where sze is the size of the vector, N_st_diag is the number of states ! where sze is the size of the vector, N_st_diag is the number of states
call hcalc(W(1,shift+1),U(1,shift+1),N_st_diag,sze) call hcalc(W(:,shift+1),U(:,shift+1),N_st_diag,sze)
else else
! Already computed in update below ! Already computed in update below
continue continue
@ -268,20 +268,20 @@ subroutine davidson_general_ext_rout_dressed(u_in,H_jj,energies,sze,N_st,N_st_di
stop stop
! call dgemm('T','N', N_st, N_st_diag, sze, 1.d0, & ! call dgemm('T','N', N_st, N_st_diag, sze, 1.d0, &
! psi_coef, size(psi_coef,1), & ! psi_coef, size(psi_coef,1), &
! U(1,shift+1), size(U,1), 0.d0, s_tmp, size(s_tmp,1)) ! U(:,shift+1), size(U,1), 0.d0, s_tmp, size(s_tmp,1))
! !
! call dgemm('N','N', sze, N_st_diag, N_st, 1.0d0, & ! call dgemm('N','N', sze, N_st_diag, N_st, 1.0d0, &
! dressing_vec, size(dressing_vec,1), s_tmp, size(s_tmp,1), & ! dressing_vec, size(dressing_vec,1), s_tmp, size(s_tmp,1), &
! 1.d0, W(1,shift+1), size(W,1)) ! 1.d0, W(:,shift+1), size(W,1))
! !
! !
! call dgemm('T','N', N_st, N_st_diag, sze, 1.d0, & ! call dgemm('T','N', N_st, N_st_diag, sze, 1.d0, &
! dressing_vec, size(dressing_vec,1), & ! dressing_vec, size(dressing_vec,1), &
! U(1,shift+1), size(U,1), 0.d0, s_tmp, size(s_tmp,1)) ! U(:,shift+1), size(U,1), 0.d0, s_tmp, size(s_tmp,1))
! !
! call dgemm('N','N', sze, N_st_diag, N_st, 1.0d0, & ! call dgemm('N','N', sze, N_st_diag, N_st, 1.0d0, &
! psi_coef, size(psi_coef,1), s_tmp, size(s_tmp,1), & ! psi_coef, size(psi_coef,1), s_tmp, size(s_tmp,1), &
! 1.d0, W(1,shift+1), size(W,1)) ! 1.d0, W(:,shift+1), size(W,1))
endif endif
endif endif
@ -370,9 +370,9 @@ subroutine davidson_general_ext_rout_dressed(u_in,H_jj,energies,sze,N_st,N_st_di
! -------------------------------------------------- ! --------------------------------------------------
call dgemm('N','N', sze, N_st_diag, shift2, & call dgemm('N','N', sze, N_st_diag, shift2, &
1.d0, U, size(U,1), y, size(y,1), 0.d0, U(1,shift2+1), size(U,1)) 1.d0, U, size(U,1), y, size(y,1), 0.d0, U(:,shift2+1), size(U,1))
call dgemm('N','N', sze, N_st_diag, shift2, & call dgemm('N','N', sze, N_st_diag, shift2, &
1.d0, W, size(W,1), y, size(y,1), 0.d0, W(1,shift2+1), size(W,1)) 1.d0, W, size(W,1), y, size(y,1), 0.d0, W(:,shift2+1), size(W,1))
! Compute residual vector and davidson step ! Compute residual vector and davidson step
! ----------------------------------------- ! -----------------------------------------
@ -386,7 +386,7 @@ subroutine davidson_general_ext_rout_dressed(u_in,H_jj,energies,sze,N_st,N_st_di
enddo enddo
if (k <= N_st) then if (k <= N_st) then
residual_norm(k) = u_dot_u(U(1,shift2+k),sze) residual_norm(k) = u_dot_u(U(:,shift2+k),sze)
to_print(1,k) = lambda(k) to_print(1,k) = lambda(k)
to_print(2,k) = residual_norm(k) to_print(2,k) = residual_norm(k)
endif endif

10
src/dav_general_mat/dav_ext_rout.irp.f
View File

@ -196,7 +196,7 @@ subroutine davidson_general_ext_rout(u_in,H_jj,energies,sze,N_st,N_st_diag_in,co
enddo enddo
! Normalize all states ! Normalize all states
do k=1,N_st_diag do k=1,N_st_diag
call normalize(u_in(1,k),sze) call normalize(u_in(:,k),sze)
enddo enddo
! Copy from the guess input "u_in" to the working vectors "U" ! Copy from the guess input "u_in" to the working vectors "U"
@ -226,7 +226,7 @@ subroutine davidson_general_ext_rout(u_in,H_jj,energies,sze,N_st,N_st_diag_in,co
call ortho_qr(U,size(U,1),sze,shift2) call ortho_qr(U,size(U,1),sze,shift2)
! it does W = H U with W(sze,N_st_diag),U(sze,N_st_diag) ! it does W = H U with W(sze,N_st_diag),U(sze,N_st_diag)
! where sze is the size of the vector, N_st_diag is the number of states ! where sze is the size of the vector, N_st_diag is the number of states
call hcalc(W(1,shift+1),U(1,shift+1),N_st_diag,sze) call hcalc(W(:,shift+1),U(:,shift+1),N_st_diag,sze)
else else
! Already computed in update below ! Already computed in update below
continue continue
@ -288,9 +288,9 @@ subroutine davidson_general_ext_rout(u_in,H_jj,energies,sze,N_st,N_st_diag_in,co
! -------------------------------------------------- ! --------------------------------------------------
call dgemm('N','N', sze, N_st_diag, shift2, & call dgemm('N','N', sze, N_st_diag, shift2, &
1.d0, U, size(U,1), y, size(y,1), 0.d0, U(1,shift2+1), size(U,1)) 1.d0, U, size(U,1), y, size(y,1), 0.d0, U(:,shift2+1), size(U,1))
call dgemm('N','N', sze, N_st_diag, shift2, & call dgemm('N','N', sze, N_st_diag, shift2, &
1.d0, W, size(W,1), y, size(y,1), 0.d0, W(1,shift2+1), size(W,1)) 1.d0, W, size(W,1), y, size(y,1), 0.d0, W(:,shift2+1), size(W,1))
! Compute residual vector and davidson step ! Compute residual vector and davidson step
! ----------------------------------------- ! -----------------------------------------
@ -304,7 +304,7 @@ subroutine davidson_general_ext_rout(u_in,H_jj,energies,sze,N_st,N_st_diag_in,co
enddo enddo
if (k <= N_st) then if (k <= N_st) then
residual_norm(k) = u_dot_u(U(1,shift2+k),sze) residual_norm(k) = u_dot_u(U(:,shift2+k),sze)
to_print(1,k) = lambda(k) to_print(1,k) = lambda(k)
to_print(2,k) = residual_norm(k) to_print(2,k) = residual_norm(k)
endif endif

12
src/dav_general_mat/dav_general.irp.f
View File

@ -206,7 +206,7 @@ subroutine davidson_general(u_in,H_jj,energies,dim_in,sze,N_st,N_st_diag_in,conv
enddo enddo
! Normalize all states ! Normalize all states
do k=1,N_st_diag do k=1,N_st_diag
call normalize(u_in(1,k),sze) call normalize(u_in(:,k),sze)
enddo enddo
! Copy from the guess input "u_in" to the working vectors "U" ! Copy from the guess input "u_in" to the working vectors "U"
@ -236,8 +236,8 @@ subroutine davidson_general(u_in,H_jj,energies,dim_in,sze,N_st,N_st_diag_in,conv
call ortho_qr(U,size(U,1),sze,shift2) call ortho_qr(U,size(U,1),sze,shift2)
call ortho_qr(U,size(U,1),sze,shift2) call ortho_qr(U,size(U,1),sze,shift2)
! call H_S2_u_0_nstates_openmp(W(1,shift+1),U(1,shift+1),N_st_diag,sze) ! call H_S2_u_0_nstates_openmp(W(:,shift+1),U(:,shift+1),N_st_diag,sze)
call hpsi(W(1,shift+1),U(1,shift+1),N_st_diag,sze,h_mat) call hpsi(W(:,shift+1),U(:,shift+1),N_st_diag,sze,h_mat)
else else
! Already computed in update below ! Already computed in update below
continue continue
@ -299,9 +299,9 @@ subroutine davidson_general(u_in,H_jj,energies,dim_in,sze,N_st,N_st_diag_in,conv
! -------------------------------------------------- ! --------------------------------------------------
call dgemm('N','N', sze, N_st_diag, shift2, & call dgemm('N','N', sze, N_st_diag, shift2, &
1.d0, U, size(U,1), y, size(y,1), 0.d0, U(1,shift2+1), size(U,1)) 1.d0, U, size(U,1), y, size(y,1), 0.d0, U(:,shift2+1), size(U,1))
call dgemm('N','N', sze, N_st_diag, shift2, & call dgemm('N','N', sze, N_st_diag, shift2, &
1.d0, W, size(W,1), y, size(y,1), 0.d0, W(1,shift2+1), size(W,1)) 1.d0, W, size(W,1), y, size(y,1), 0.d0, W(:,shift2+1), size(W,1))
! Compute residual vector and davidson step ! Compute residual vector and davidson step
! ----------------------------------------- ! -----------------------------------------
@ -315,7 +315,7 @@ subroutine davidson_general(u_in,H_jj,energies,dim_in,sze,N_st,N_st_diag_in,conv
enddo enddo
if (k <= N_st) then if (k <= N_st) then
residual_norm(k) = u_dot_u(U(1,shift2+k),sze) residual_norm(k) = u_dot_u(U(:,shift2+k),sze)
to_print(1,k) = lambda(k) to_print(1,k) = lambda(k)
to_print(2,k) = residual_norm(k) to_print(2,k) = residual_norm(k)
endif endif