From 7bb0f7d963397f4e53a3409159fecc1e28754821 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner LCT Date: Mon, 17 Jun 2019 11:37:15 +0200 Subject: [PATCH 01/59] working on scan --- src/dft_utils_one_e/ec_scan.irp.f | 117 +++++++++++++++++++++++++++--- 1 file changed, 105 insertions(+), 12 deletions(-) diff --git a/src/dft_utils_one_e/ec_scan.irp.f b/src/dft_utils_one_e/ec_scan.irp.f index 7a4b587b..0833ddec 100644 --- a/src/dft_utils_one_e/ec_scan.irp.f +++ b/src/dft_utils_one_e/ec_scan.irp.f @@ -37,7 +37,8 @@ double precision function ec_scan(rho_a,rho_b,tau,grad_rho_2) gama = 0.031091d0 ! correlation energy lsda1 call ec_only_lda_sr(0.d0,nup,ndo,e_c_lsda1) - + ! correlation energy per particle + e_c_lsda1 = e_c_lsda1/rho xi = spin_d/rho rs = (cst_43 * pi * rho)**(-cst_13) s = drho/( 2.d0 * cst_3pi2**(cst_13) * rho**cst_43 ) @@ -61,7 +62,11 @@ double precision function ec_scan(rho_a,rho_b,tau,grad_rho_2) g_at2 = 1.d0/(1.d0 + 4.d0 * a*t*t)**0.25d0 h1 = gama * phi_3 * dlog(1.d0 + w_1 * (1.d0 - g_at2)) ! interpolation function - fc_alpha = dexp(-c_1c * alpha * inv_1alph) * step_f(cst_1alph) - d_c * dexp(c_2c * inv_1alph) * step_f(-cst_1alph) + if(cst_1alph.gt.0.d0)then + fc_alpha = dexp(-c_1c * alpha * inv_1alph) + else + fc_alpha = - d_c * dexp(c_2c * inv_1alph) + endif ! first part of the correlation energy e_c_1 = e_c_lsda1 + h1 @@ -82,19 +87,107 @@ double precision function ec_scan(rho_a,rho_b,tau,grad_rho_2) ec_scan = e_c_1 + fc_alpha * (e_c_0 - e_c_1) end -double precision function step_f(x) - implicit none - double precision, intent(in) :: x - if(x.lt.0.d0)then - step_f = 0.d0 - else - step_f = 1.d0 - endif -end - double precision function beta_rs(rs) implicit none double precision, intent(in) ::rs beta_rs(rs) = 0.066725d0 * (1.d0 + 0.1d0 * rs)/(1.d0 + 0.1778d0 * rs) +!beta_rs(rs) = 0.066725d0 end + +double precision function ec_scan_print(rho_a,rho_b,tau,grad_rho_2) + include 'constants.include.F' + implicit none + double precision, intent(in) :: rho_a,rho_b,tau,grad_rho_2 + double precision :: cst_13,cst_23,cst_43,cst_53,rho_inv,cst_18,cst_3pi2 + double precision :: thr,nup,ndo,xi,s,spin_d,drho,drho2,rho,inv_1alph,e_c_lsda1,h0 + double precision :: rs,t_w,t_unif,ds_xi,alpha,fc_alpha,step_f,cst_1alph,beta_inf + double precision :: c_1c,c_2c,d_c,e_c_ldsa1,h1,phi,t,beta_rs,gama,a,w_1,g_at2,phi_3,e_c_1 + double precision :: b_1c,b_2c,b_3c,dx_xi,gc_xi,e_c_lsda0,w_0,g_inf,cx_xi,x_inf,f0,e_c_0 + thr = 1.d-12 + nup = max(rho_a,thr) + ndo = max(rho_b,thr) + rho = nup + ndo + ec_scan_print = 0.d0 + if((rho).lt.thr)return + ! constants ... + rho_inv = 1.d0/rho + cst_13 = 1.d0/3.d0 + cst_23 = 2.d0 * cst_13 + cst_43 = 4.d0 * cst_13 + cst_53 = 5.d0 * cst_13 + cst_18 = 1.d0/8.d0 + cst_3pi2 = 3.d0 * pi*pi + drho2 = max(grad_rho_2,thr) + drho = dsqrt(drho2) + if((nup-ndo).gt.0.d0)then + spin_d = max(nup-ndo,thr) + else + spin_d = min(nup-ndo,-thr) + endif + c_1c = 0.64d0 + c_2c = 1.5d0 + d_c = 0.7d0 + b_1c = 0.0285764d0 + b_2c = 0.0889d0 + b_3c = 0.125541d0 + gama = 0.031091d0 + ! correlation energy lsda1 + call ec_only_lda_sr(0.d0,nup,ndo,e_c_lsda1) + ! correlation energy per particle + e_c_lsda1 = e_c_lsda1/rho + xi = spin_d/rho + rs = (cst_43 * pi * rho)**(-cst_13) + s = drho/( 2.d0 * cst_3pi2**(cst_13) * rho**cst_43 ) + t_w = drho2 * cst_18 * rho_inv + ds_xi = 0.5d0 * ( (1.d0+xi)**cst_53 + (1.d0 - xi)**cst_53) + t_unif = 0.3d0 * (cst_3pi2)**cst_23 * rho**cst_53*ds_xi + t_unif = max(t_unif,thr) + alpha = (tau - t_w)/t_unif + cst_1alph= 1.d0 - alpha + if(cst_1alph.gt.0.d0)then + cst_1alph= max(cst_1alph,thr) + else + cst_1alph= min(cst_1alph,-thr) + endif + inv_1alph= 1.d0/cst_1alph + phi = 0.5d0 * ( (1.d0+xi)**cst_23 + (1.d0 - xi)**cst_23) + phi_3 = phi*phi*phi + t = (cst_3pi2/16.d0)**cst_13 * s / (phi * rs**0.5d0) + w_1 = dexp(-e_c_lsda1/(gama * phi_3)) - 1.d0 + a = beta_rs(rs) /(gama * w_1) + g_at2 = 1.d0/(1.d0 + 4.d0 * a*t*t)**0.25d0 + h1 = gama * phi_3 * dlog(1.d0 + w_1 * (1.d0 - g_at2)) + print*,'w_1 g_at2 ' + print*, w_1 , g_at2 + print*,'gama phi_3 1.d0 + w_1 * (1.d0 - g_at2)' + print*, gama , phi_3 , 1.d0 + w_1 * (1.d0 - g_at2) + ! interpolation function + if(cst_1alph.gt.0.d0)then + fc_alpha = dexp(-c_1c * alpha * inv_1alph) + else + fc_alpha = - d_c * dexp(c_2c * inv_1alph) + endif + ! first part of the correlation energy + e_c_1 = e_c_lsda1 + h1 + print*,'e_c_lsda1 h1 ' + print*, e_c_lsda1 , h1 + + dx_xi = 0.5d0 * ( (1.d0+xi)**cst_43 + (1.d0 - xi)**cst_43) + gc_xi = (1.d0 - 2.3631d0 * (dx_xi - 1.d0) ) * (1.d0 - xi**12.d0) + e_c_lsda0= - b_1c / (1.d0 + b_2c * rs**0.5d0 + b_3c * rs) + w_0 = dexp(-e_c_lsda0/b_1c) - 1.d0 + beta_inf = 0.066725d0 * 0.1d0 / 0.1778d0 + cx_xi = -3.d0/(4.d0*pi) * (9.d0 * pi/4.d0)**cst_13 * dx_xi + + x_inf = 0.128026d0 + f0 = -0.9d0 + g_inf = 1.d0/(1.d0 + 4.d0 * x_inf * s*s)**0.25d0 + + h0 = b_1c * dlog(1.d0 + w_0 * (1.d0 - g_inf)) + e_c_0 = (e_c_lsda0 + h0) * gc_xi + + ec_scan_print = e_c_1 + fc_alpha * (e_c_0 - e_c_1) + write(*,*)' e_c_1 , fc_alpha , e_c_0 ' + write(*,*) e_c_1 , fc_alpha , e_c_0 +end From a035f42c7664f2fadbce93f6f33f9d7bf4bfb7af Mon Sep 17 00:00:00 2001 From: Emmanuel Giner LCT Date: Mon, 17 Jun 2019 11:59:19 +0200 Subject: [PATCH 02/59] modified scan --- src/dft_utils_one_e/ec_scan.irp.f | 99 +------------------------------ 1 file changed, 1 insertion(+), 98 deletions(-) diff --git a/src/dft_utils_one_e/ec_scan.irp.f b/src/dft_utils_one_e/ec_scan.irp.f index 0833ddec..0df70572 100644 --- a/src/dft_utils_one_e/ec_scan.irp.f +++ b/src/dft_utils_one_e/ec_scan.irp.f @@ -90,104 +90,7 @@ end double precision function beta_rs(rs) implicit none double precision, intent(in) ::rs - beta_rs(rs) = 0.066725d0 * (1.d0 + 0.1d0 * rs)/(1.d0 + 0.1778d0 * rs) -!beta_rs(rs) = 0.066725d0 + beta_rs = 0.066725d0 * (1.d0 + 0.1d0 * rs)/(1.d0 + 0.1778d0 * rs) end -double precision function ec_scan_print(rho_a,rho_b,tau,grad_rho_2) - include 'constants.include.F' - implicit none - double precision, intent(in) :: rho_a,rho_b,tau,grad_rho_2 - double precision :: cst_13,cst_23,cst_43,cst_53,rho_inv,cst_18,cst_3pi2 - double precision :: thr,nup,ndo,xi,s,spin_d,drho,drho2,rho,inv_1alph,e_c_lsda1,h0 - double precision :: rs,t_w,t_unif,ds_xi,alpha,fc_alpha,step_f,cst_1alph,beta_inf - double precision :: c_1c,c_2c,d_c,e_c_ldsa1,h1,phi,t,beta_rs,gama,a,w_1,g_at2,phi_3,e_c_1 - double precision :: b_1c,b_2c,b_3c,dx_xi,gc_xi,e_c_lsda0,w_0,g_inf,cx_xi,x_inf,f0,e_c_0 - thr = 1.d-12 - nup = max(rho_a,thr) - ndo = max(rho_b,thr) - rho = nup + ndo - ec_scan_print = 0.d0 - if((rho).lt.thr)return - ! constants ... - rho_inv = 1.d0/rho - cst_13 = 1.d0/3.d0 - cst_23 = 2.d0 * cst_13 - cst_43 = 4.d0 * cst_13 - cst_53 = 5.d0 * cst_13 - cst_18 = 1.d0/8.d0 - cst_3pi2 = 3.d0 * pi*pi - drho2 = max(grad_rho_2,thr) - drho = dsqrt(drho2) - if((nup-ndo).gt.0.d0)then - spin_d = max(nup-ndo,thr) - else - spin_d = min(nup-ndo,-thr) - endif - c_1c = 0.64d0 - c_2c = 1.5d0 - d_c = 0.7d0 - b_1c = 0.0285764d0 - b_2c = 0.0889d0 - b_3c = 0.125541d0 - gama = 0.031091d0 - ! correlation energy lsda1 - call ec_only_lda_sr(0.d0,nup,ndo,e_c_lsda1) - ! correlation energy per particle - e_c_lsda1 = e_c_lsda1/rho - xi = spin_d/rho - rs = (cst_43 * pi * rho)**(-cst_13) - s = drho/( 2.d0 * cst_3pi2**(cst_13) * rho**cst_43 ) - t_w = drho2 * cst_18 * rho_inv - ds_xi = 0.5d0 * ( (1.d0+xi)**cst_53 + (1.d0 - xi)**cst_53) - t_unif = 0.3d0 * (cst_3pi2)**cst_23 * rho**cst_53*ds_xi - t_unif = max(t_unif,thr) - alpha = (tau - t_w)/t_unif - cst_1alph= 1.d0 - alpha - if(cst_1alph.gt.0.d0)then - cst_1alph= max(cst_1alph,thr) - else - cst_1alph= min(cst_1alph,-thr) - endif - inv_1alph= 1.d0/cst_1alph - phi = 0.5d0 * ( (1.d0+xi)**cst_23 + (1.d0 - xi)**cst_23) - phi_3 = phi*phi*phi - t = (cst_3pi2/16.d0)**cst_13 * s / (phi * rs**0.5d0) - w_1 = dexp(-e_c_lsda1/(gama * phi_3)) - 1.d0 - a = beta_rs(rs) /(gama * w_1) - g_at2 = 1.d0/(1.d0 + 4.d0 * a*t*t)**0.25d0 - h1 = gama * phi_3 * dlog(1.d0 + w_1 * (1.d0 - g_at2)) - print*,'w_1 g_at2 ' - print*, w_1 , g_at2 - print*,'gama phi_3 1.d0 + w_1 * (1.d0 - g_at2)' - print*, gama , phi_3 , 1.d0 + w_1 * (1.d0 - g_at2) - ! interpolation function - if(cst_1alph.gt.0.d0)then - fc_alpha = dexp(-c_1c * alpha * inv_1alph) - else - fc_alpha = - d_c * dexp(c_2c * inv_1alph) - endif - ! first part of the correlation energy - e_c_1 = e_c_lsda1 + h1 - print*,'e_c_lsda1 h1 ' - print*, e_c_lsda1 , h1 - - dx_xi = 0.5d0 * ( (1.d0+xi)**cst_43 + (1.d0 - xi)**cst_43) - gc_xi = (1.d0 - 2.3631d0 * (dx_xi - 1.d0) ) * (1.d0 - xi**12.d0) - e_c_lsda0= - b_1c / (1.d0 + b_2c * rs**0.5d0 + b_3c * rs) - w_0 = dexp(-e_c_lsda0/b_1c) - 1.d0 - beta_inf = 0.066725d0 * 0.1d0 / 0.1778d0 - cx_xi = -3.d0/(4.d0*pi) * (9.d0 * pi/4.d0)**cst_13 * dx_xi - - x_inf = 0.128026d0 - f0 = -0.9d0 - g_inf = 1.d0/(1.d0 + 4.d0 * x_inf * s*s)**0.25d0 - - h0 = b_1c * dlog(1.d0 + w_0 * (1.d0 - g_inf)) - e_c_0 = (e_c_lsda0 + h0) * gc_xi - - ec_scan_print = e_c_1 + fc_alpha * (e_c_0 - e_c_1) - write(*,*)' e_c_1 , fc_alpha , e_c_0 ' - write(*,*) e_c_1 , fc_alpha , e_c_0 -end From 2f340f4841a986b47362f9e057fa04434a4eaeca Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 24 Jun 2019 15:32:26 +0200 Subject: [PATCH 03/59] CAS-CI with no vvvv --- src/casscf/NEED | 3 +++ src/casscf/README.rst | 5 +++++ src/casscf/casscf.irp.f | 14 ++++++++++++++ src/casscf/class.irp.f | 12 ++++++++++++ src/cipsi/selection.irp.f | 10 ++++++++++ src/fci/class.irp.f | 2 ++ 6 files changed, 46 insertions(+) create mode 100644 src/casscf/NEED create mode 100644 src/casscf/README.rst create mode 100644 src/casscf/casscf.irp.f create mode 100644 src/casscf/class.irp.f diff --git a/src/casscf/NEED b/src/casscf/NEED new file mode 100644 index 00000000..d7aff476 --- /dev/null +++ b/src/casscf/NEED @@ -0,0 +1,3 @@ +cipsi +selectors_full +generators_cas diff --git a/src/casscf/README.rst b/src/casscf/README.rst new file mode 100644 index 00000000..08bfd95b --- /dev/null +++ b/src/casscf/README.rst @@ -0,0 +1,5 @@ +====== +casscf +====== + +|CASSCF| program with the CIPSI algorithm. diff --git a/src/casscf/casscf.irp.f b/src/casscf/casscf.irp.f new file mode 100644 index 00000000..28f56069 --- /dev/null +++ b/src/casscf/casscf.irp.f @@ -0,0 +1,14 @@ +program casscf_new + implicit none + BEGIN_DOC +! TODO : Put the documentation of the program here + END_DOC + no_vvvv_integrals = .True. + SOFT_TOUCH no_vvvv_integrals + call run +end + +subroutine run + implicit none + call run_cipsi +end diff --git a/src/casscf/class.irp.f b/src/casscf/class.irp.f new file mode 100644 index 00000000..7360a661 --- /dev/null +++ b/src/casscf/class.irp.f @@ -0,0 +1,12 @@ + BEGIN_PROVIDER [ logical, do_only_1h1p ] +&BEGIN_PROVIDER [ logical, do_only_cas ] +&BEGIN_PROVIDER [ logical, do_ddci ] + implicit none + BEGIN_DOC + ! In the CAS case, all those are always false except do_only_cas + END_DOC + do_only_cas = .True. + do_only_1h1p = .False. + do_ddci = .False. +END_PROVIDER + diff --git a/src/cipsi/selection.irp.f b/src/cipsi/selection.irp.f index df31bc39..062b44bf 100644 --- a/src/cipsi/selection.irp.f +++ b/src/cipsi/selection.irp.f @@ -683,6 +683,16 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d if( sum(abs(mat(1:N_states, p1, p2))) == 0d0) cycle call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + if (do_only_cas) then + integer, external :: number_of_holes, number_of_particles + if (number_of_particles(det)>0) then + cycle + endif + if (number_of_holes(det)>0) then + cycle + endif + endif + if (do_ddci) then logical, external :: is_a_two_holes_two_particles if (is_a_two_holes_two_particles(det)) then diff --git a/src/fci/class.irp.f b/src/fci/class.irp.f index 425691ae..b4a68ac2 100644 --- a/src/fci/class.irp.f +++ b/src/fci/class.irp.f @@ -1,10 +1,12 @@ BEGIN_PROVIDER [ logical, do_only_1h1p ] +&BEGIN_PROVIDER [ logical, do_only_cas ] &BEGIN_PROVIDER [ logical, do_ddci ] implicit none BEGIN_DOC ! In the FCI case, all those are always false END_DOC do_only_1h1p = .False. + do_only_cas = .False. do_ddci = .False. END_PROVIDER From 33f070ab0413abf462d232ca0fd075b51a31af8e Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 24 Jun 2019 15:37:09 +0200 Subject: [PATCH 04/59] CAS-CI works --- src/casscf/EZFIO.cfg | 13 +++++++++++++ src/casscf/save_energy.irp.f | 9 +++++++++ 2 files changed, 22 insertions(+) create mode 100644 src/casscf/EZFIO.cfg create mode 100644 src/casscf/save_energy.irp.f diff --git a/src/casscf/EZFIO.cfg b/src/casscf/EZFIO.cfg new file mode 100644 index 00000000..d5526673 --- /dev/null +++ b/src/casscf/EZFIO.cfg @@ -0,0 +1,13 @@ +[energy] +type: double precision +doc: Calculated Selected |FCI| energy +interface: ezfio +size: (determinants.n_states) + +[energy_pt2] +type: double precision +doc: Calculated |FCI| energy + |PT2| +interface: ezfio +size: (determinants.n_states) + + diff --git a/src/casscf/save_energy.irp.f b/src/casscf/save_energy.irp.f new file mode 100644 index 00000000..8729c5af --- /dev/null +++ b/src/casscf/save_energy.irp.f @@ -0,0 +1,9 @@ +subroutine save_energy(E,pt2) + implicit none + BEGIN_DOC +! Saves the energy in |EZFIO|. + END_DOC + double precision, intent(in) :: E(N_states), pt2(N_states) + call ezfio_set_casscf_energy(E(1:N_states)) + call ezfio_set_casscf_energy_pt2(E(1:N_states)+pt2(1:N_states)) +end From d29f82c0800de5baf37047b010b8f868cf630cf5 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 24 Jun 2019 16:42:16 +0200 Subject: [PATCH 05/59] CAS-CI and wdens merged --- src/casscf/bavard.irp.f | 6 + src/casscf/bielec_create.irp.f | 118 +++++++ src/casscf/casscf.irp.f | 4 +- src/casscf/densities.irp.f | 177 +++++++++++ src/casscf/det_manip.irp.f | 131 ++++++++ src/casscf/driver_wdens.irp.f | 154 +++++++++ src/casscf/natorb.irp.f | 548 +++++++++++++++++++++++++++++++++ src/casscf/tot_en.irp.f | 122 ++++++++ 8 files changed, 1259 insertions(+), 1 deletion(-) create mode 100644 src/casscf/bavard.irp.f create mode 100644 src/casscf/bielec_create.irp.f create mode 100644 src/casscf/densities.irp.f create mode 100644 src/casscf/det_manip.irp.f create mode 100644 src/casscf/driver_wdens.irp.f create mode 100644 src/casscf/natorb.irp.f create mode 100644 src/casscf/tot_en.irp.f diff --git a/src/casscf/bavard.irp.f b/src/casscf/bavard.irp.f new file mode 100644 index 00000000..de71a346 --- /dev/null +++ b/src/casscf/bavard.irp.f @@ -0,0 +1,6 @@ +! -*- F90 -*- +BEGIN_PROVIDER [logical, bavard] + bavard=.true. + bavard=.false. +END_PROVIDER + diff --git a/src/casscf/bielec_create.irp.f b/src/casscf/bielec_create.irp.f new file mode 100644 index 00000000..7e6d16c8 --- /dev/null +++ b/src/casscf/bielec_create.irp.f @@ -0,0 +1,118 @@ +! -*- F90 -*- + BEGIN_PROVIDER[real*8, bielec_PQxxtmp, (mo_num, mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb)] +&BEGIN_PROVIDER[real*8, bielec_PxxQtmp, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb, mo_num)] +&BEGIN_PROVIDER[integer, num_PQxx_written] +&BEGIN_PROVIDER[integer, num_PxxQ_written] +BEGIN_DOC +! bielec_PQxx : integral (pq|xx) with p,q arbitrary, x core or active +! bielec_PxxQ : integral (px|xq) with p,q arbitrary, x core or active +! indices are unshifted orbital numbers +END_DOC + implicit none + integer :: i,j,ii,jj,p,q,i3,j3,t3,v3 + double precision, allocatable :: integrals_array1(:,:) + double precision, allocatable :: integrals_array2(:,:) + real*8 :: mo_two_e_integral + + allocate(integrals_array1(mo_num,mo_num)) + allocate(integrals_array2(mo_num,mo_num)) + + do i=1,n_core_orb+n_act_orb + do j=1,n_core_orb+n_act_orb + do p=1,mo_num + do q=1,mo_num + bielec_PQxxtmp(p,q,i,j)=0.D0 + bielec_PxxQtmp(p,i,j,q)=0.D0 + end do + end do + end do + end do + + do i=1,n_core_orb + ii=list_core(i) + do j=i,n_core_orb + jj=list_core(j) +! (ij|pq) + call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array1,mo_integrals_map) +! (ip|qj) + call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array2,mo_integrals_map) + do p=1,mo_num + do q=1,mo_num + bielec_PQxxtmp(p,q,i,j)=integrals_array1(p,q) + bielec_PQxxtmp(p,q,j,i)=integrals_array1(p,q) + bielec_PxxQtmp(p,i,j,q)=integrals_array2(p,q) + bielec_PxxQtmp(p,j,i,q)=integrals_array2(q,p) + end do + end do + end do + do j=1,n_act_orb + jj=list_act(j) + j3=j+n_core_orb +! (ij|pq) + call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array1,mo_integrals_map) +! (ip|qj) + call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array2,mo_integrals_map) + do p=1,mo_num + do q=1,mo_num + bielec_PQxxtmp(p,q,i,j3)=integrals_array1(p,q) + bielec_PQxxtmp(p,q,j3,i)=integrals_array1(p,q) + bielec_PxxQtmp(p,i,j3,q)=integrals_array2(p,q) + bielec_PxxQtmp(p,j3,i,q)=integrals_array2(q,p) + end do + end do + end do + end do + do i=1,n_act_orb + ii=list_act(i) + i3=i+n_core_orb + do j=i,n_act_orb + jj=list_act(j) + j3=j+n_core_orb +! (ij|pq) + call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array1,mo_integrals_map) +! (ip|qj) + call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array2,mo_integrals_map) + do p=1,mo_num + do q=1,mo_num + bielec_PQxxtmp(p,q,i3,j3)=integrals_array1(p,q) + bielec_PQxxtmp(p,q,j3,i3)=integrals_array1(p,q) + bielec_PxxQtmp(p,i3,j3,q)=integrals_array2(p,q) + bielec_PxxQtmp(p,j3,i3,q)=integrals_array2(q,p) + end do + end do + end do + end do + write(6,*) ' provided integrals (PQ|xx) ' + write(6,*) ' provided integrals (Px|xQ) ' +!!$ write(6,*) ' 1 1 1 2 = ',bielec_PQxxtmp(2,2,2,3),bielec_PxxQtmp(2,2,2,3) +END_PROVIDER + +BEGIN_PROVIDER[real*8, bielecCItmp, (n_act_orb,n_act_orb,n_act_orb, mo_num)] +BEGIN_DOC +! bielecCI : integrals (tu|vp) with p arbitrary, tuv active +! index p runs over the whole basis, t,u,v only over the active orbitals +END_DOC + implicit none + integer :: i,j,k,p,t,u,v + double precision, allocatable :: integrals_array1(:) + real*8 :: mo_two_e_integral + + allocate(integrals_array1(mo_num)) + + do i=1,n_act_orb + t=list_act(i) + do j=1,n_act_orb + u=list_act(j) + do k=1,n_act_orb + v=list_act(k) +! (tu|vp) + call get_mo_two_e_integrals(t,u,v,mo_num,integrals_array1,mo_integrals_map) + do p=1,mo_num + bielecCItmp(i,k,j,p)=integrals_array1(p) + end do + end do + end do + end do + write(6,*) ' provided integrals (tu|xP) ' +END_PROVIDER + diff --git a/src/casscf/casscf.irp.f b/src/casscf/casscf.irp.f index 28f56069..c08dd032 100644 --- a/src/casscf/casscf.irp.f +++ b/src/casscf/casscf.irp.f @@ -1,4 +1,4 @@ -program casscf_new +program casscf implicit none BEGIN_DOC ! TODO : Put the documentation of the program here @@ -11,4 +11,6 @@ end subroutine run implicit none call run_cipsi + call driver_wdens + end diff --git a/src/casscf/densities.irp.f b/src/casscf/densities.irp.f new file mode 100644 index 00000000..77f5593e --- /dev/null +++ b/src/casscf/densities.irp.f @@ -0,0 +1,177 @@ +! -*- F90 -*- +use bitmasks ! you need to include the bitmasks_module.f90 features + + BEGIN_PROVIDER [real*8, D0tu, (n_act_orb,n_act_orb) ] +&BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ] +BEGIN_DOC +! the first-order density matrix in the basis of the starting MOs +! the second-order density matrix in the basis of the starting MOs +! matrices are state averaged +! +! we use the spin-free generators of mono-excitations +! E_pq destroys q and creates p +! D_pq = <0|E_pq|0> = D_qp +! P_pqrs = 1/2 <0|E_pq E_rs - delta_qr E_ps|0> +! +END_DOC + implicit none + integer :: t,u,v,x,mu,nu,istate,ispin,jspin,ihole,ipart,jhole,jpart + integer :: ierr + integer(bit_kind), allocatable :: det_mu(:,:) + integer(bit_kind), allocatable :: det_mu_ex(:,:) + integer(bit_kind), allocatable :: det_mu_ex1(:,:) + integer(bit_kind), allocatable :: det_mu_ex11(:,:) + integer(bit_kind), allocatable :: det_mu_ex12(:,:) + integer(bit_kind), allocatable :: det_mu_ex2(:,:) + integer(bit_kind), allocatable :: det_mu_ex21(:,:) + integer(bit_kind), allocatable :: det_mu_ex22(:,:) + real*8 :: phase1,phase11,phase12,phase2,phase21,phase22 + integer :: nu1,nu2,nu11,nu12,nu21,nu22 + integer :: ierr1,ierr2,ierr11,ierr12,ierr21,ierr22 + real*8 :: cI_mu(N_states),term + allocate(det_mu(N_int,2)) + allocate(det_mu_ex(N_int,2)) + allocate(det_mu_ex1(N_int,2)) + allocate(det_mu_ex11(N_int,2)) + allocate(det_mu_ex12(N_int,2)) + allocate(det_mu_ex2(N_int,2)) + allocate(det_mu_ex21(N_int,2)) + allocate(det_mu_ex22(N_int,2)) + + write(6,*) ' providing density matrices D0 and P0 ' + +! set all to zero + do t=1,n_act_orb + do u=1,n_act_orb + D0tu(u,t)=0.D0 + do v=1,n_act_orb + do x=1,n_act_orb + P0tuvx(x,v,u,t)=0.D0 + end do + end do + end do + end do + +! first loop: we apply E_tu, once for D_tu, once for -P_tvvu + do mu=1,n_det + call det_extract(det_mu,mu,N_int) + do istate=1,n_states + cI_mu(istate)=psi_coef(mu,istate) + end do + do t=1,n_act_orb + ipart=list_act(t) + do u=1,n_act_orb + ihole=list_act(u) +! apply E_tu + call det_copy(det_mu,det_mu_ex1,N_int) + call det_copy(det_mu,det_mu_ex2,N_int) + call do_spinfree_mono_excitation(det_mu,det_mu_ex1 & + ,det_mu_ex2,nu1,nu2,ihole,ipart,phase1,phase2,ierr1,ierr2) +! det_mu_ex1 is in the list + if (nu1.ne.-1) then + do istate=1,n_states + term=cI_mu(istate)*psi_coef(nu1,istate)*phase1 + D0tu(t,u)+=term +! and we fill P0_tvvu + do v=1,n_act_orb + P0tuvx(t,v,v,u)-=term + end do + end do + end if +! det_mu_ex2 is in the list + if (nu2.ne.-1) then + do istate=1,n_states + term=cI_mu(istate)*psi_coef(nu2,istate)*phase2 + D0tu(t,u)+=term + do v=1,n_act_orb + P0tuvx(t,v,v,u)-=term + end do + end do + end if + end do + end do + end do +! now we do the double excitation E_tu E_vx |0> + do mu=1,n_det + call det_extract(det_mu,mu,N_int) + do istate=1,n_states + cI_mu(istate)=psi_coef(mu,istate) + end do + do v=1,n_act_orb + ipart=list_act(v) + do x=1,n_act_orb + ihole=list_act(x) +! apply E_vx + call det_copy(det_mu,det_mu_ex1,N_int) + call det_copy(det_mu,det_mu_ex2,N_int) + call do_spinfree_mono_excitation(det_mu,det_mu_ex1 & + ,det_mu_ex2,nu1,nu2,ihole,ipart,phase1,phase2,ierr1,ierr2) +! we apply E_tu to the first resultant determinant, thus E_tu E_vx |0> + if (ierr1.eq.1) then + do t=1,n_act_orb + jpart=list_act(t) + do u=1,n_act_orb + jhole=list_act(u) + call det_copy(det_mu_ex1,det_mu_ex11,N_int) + call det_copy(det_mu_ex1,det_mu_ex12,N_int) + call do_spinfree_mono_excitation(det_mu_ex1,det_mu_ex11 & + ,det_mu_ex12,nu11,nu12,jhole,jpart,phase11,phase12,ierr11,ierr12) + if (nu11.ne.-1) then + do istate=1,n_states + P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu11,istate) & + *phase11*phase1 + end do + end if + if (nu12.ne.-1) then + do istate=1,n_states + P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu12,istate) & + *phase12*phase1 + end do + end if + end do + end do + end if + +! we apply E_tu to the second resultant determinant + if (ierr2.eq.1) then + do t=1,n_act_orb + jpart=list_act(t) + do u=1,n_act_orb + jhole=list_act(u) + call det_copy(det_mu_ex2,det_mu_ex21,N_int) + call det_copy(det_mu_ex2,det_mu_ex22,N_int) + call do_spinfree_mono_excitation(det_mu_ex2,det_mu_ex21 & + ,det_mu_ex22,nu21,nu22,jhole,jpart,phase21,phase22,ierr21,ierr22) + if (nu21.ne.-1) then + do istate=1,n_states + P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu21,istate) & + *phase21*phase2 + end do + end if + if (nu22.ne.-1) then + do istate=1,n_states + P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu22,istate) & + *phase22*phase2 + end do + end if + end do + end do + end if + + end do + end do + end do + +! we average by just dividing by the number of states + do x=1,n_act_orb + do v=1,n_act_orb + D0tu(v,x)*=1.0D0/dble(N_states) + do u=1,n_act_orb + do t=1,n_act_orb + P0tuvx(t,u,v,x)*=0.5D0/dble(N_states) + end do + end do + end do + end do + +END_PROVIDER diff --git a/src/casscf/det_manip.irp.f b/src/casscf/det_manip.irp.f new file mode 100644 index 00000000..c8e6c08a --- /dev/null +++ b/src/casscf/det_manip.irp.f @@ -0,0 +1,131 @@ +! -*- F90 -*- +use bitmasks ! you need to include the bitmasks_module.f90 features + + subroutine do_signed_mono_excitation(key1,key2,nu,ihole,ipart, & + ispin,phase,ierr) +BEGIN_DOC +! we create the mono-excitation, and determine, if possible, +! the phase and the number in the list of determinants +END_DOC + implicit none + integer(bit_kind) :: key1(N_int,2),key2(N_int,2) + integer(bit_kind), allocatable :: keytmp(:,:) + integer :: exc(0:2,2,2),ihole,ipart,ierr,nu,ispin + real*8 :: phase + logical :: found + allocate(keytmp(N_int,2)) + + nu=-1 + phase=1.D0 + ierr=0 + call det_copy(key1,key2,N_int) +! write(6,*) ' key2 before excitation ',ihole,' -> ',ipart,' spin = ',ispin +! call print_det(key2,N_int) + call do_single_excitation(key2,ihole,ipart,ispin,ierr) +! write(6,*) ' key2 after ',ihole,' -> ',ipart,' spin = ',ispin +! call print_det(key2,N_int) +! write(6,*) ' excitation ',ihole,' -> ',ipart,' gives ierr = ',ierr + if (ierr.eq.1) then +! excitation is possible +! get the phase + call get_single_excitation(key1,key2,exc,phase,N_int) +! get the number in the list + found=.false. + nu=0 + do while (.not.found) + nu+=1 + if (nu.gt.N_det) then +! the determinant is possible, but not in the list + found=.true. + nu=-1 + else + call det_extract(keytmp,nu,N_int) +integer :: i,ii + found=.true. + do ii=1,2 + do i=1,N_int + if (keytmp(i,ii).ne.key2(i,ii)) then + found=.false. + end if + end do + end do + end if + end do +! if (found) then +! if (nu.eq.-1) then +! write(6,*) ' image not found in the list, thus nu = ',nu +! else +! write(6,*) ' found in the list as No ',nu,' phase = ',phase +! end if +! end if + end if +! +! we found the new string, the phase, and possibly the number in the list +! + end subroutine do_signed_mono_excitation + + subroutine det_extract(key,nu,Nint) +BEGIN_DOC +! extract a determinant from the list of determinants +END_DOC + implicit none + integer :: ispin,i,nu,Nint + integer(bit_kind) :: key(Nint,2) + do ispin=1,2 + do i=1,Nint + key(i,ispin)=psi_det(i,ispin,nu) + end do + end do + end subroutine det_extract + + subroutine det_copy(key1,key2,Nint) + use bitmasks ! you need to include the bitmasks_module.f90 features +BEGIN_DOC +! copy a determinant from key1 to key2 +END_DOC + implicit none + integer :: ispin,i,Nint + integer(bit_kind) :: key1(Nint,2),key2(Nint,2) + do ispin=1,2 + do i=1,Nint + key2(i,ispin)=key1(i,ispin) + end do + end do + end subroutine det_copy + + subroutine do_spinfree_mono_excitation(key_in,key_out1,key_out2 & + ,nu1,nu2,ihole,ipart,phase1,phase2,ierr,jerr) +BEGIN_DOC +! we create the spin-free mono-excitation E_pq=(a^+_p a_q + a^+_P a_Q) +! we may create two determinants as result +! +END_DOC + implicit none + integer(bit_kind) :: key_in(N_int,2),key_out1(N_int,2) + integer(bit_kind) :: key_out2(N_int,2) + integer :: ihole,ipart,ierr,jerr,nu1,nu2 + integer :: ispin + real*8 :: phase1,phase2 + +! write(6,*) ' applying E_',ipart,ihole,' on determinant ' +! call print_det(key_in,N_int) + +! spin alpha + ispin=1 + call do_signed_mono_excitation(key_in,key_out1,nu1,ihole & + ,ipart,ispin,phase1,ierr) +! if (ierr.eq.1) then +! write(6,*) ' 1 result is ',nu1,phase1 +! call print_det(key_out1,N_int) +! end if +! spin beta + ispin=2 + call do_signed_mono_excitation(key_in,key_out2,nu2,ihole & + ,ipart,ispin,phase2,jerr) +! if (jerr.eq.1) then +! write(6,*) ' 2 result is ',nu2,phase2 +! call print_det(key_out2,N_int) +! end if + + end subroutine do_spinfree_mono_excitation + diff --git a/src/casscf/driver_wdens.irp.f b/src/casscf/driver_wdens.irp.f new file mode 100644 index 00000000..263e8441 --- /dev/null +++ b/src/casscf/driver_wdens.irp.f @@ -0,0 +1,154 @@ + subroutine driver_wdens + implicit none + integer :: istate,p,q,r,s,indx,i,j + + + write(6,*) ' total energy = ',eone+etwo+ecore + write(6,*) ' generating natural orbitals ' + write(6,*) + write(6,*) + call trf_to_natorb + + write(6,*) ' all data available ! ' + write(6,*) ' writing out files ' + + open(unit=12,file='D0tu.dat',form='formatted',status='unknown') + do p=1,n_act_orb + do q=1,n_act_orb + if (abs(D0tu(p,q)).gt.1.D-12) then + write(12,'(2i8,E20.12)') p,q,D0tu(p,q) + end if + end do + end do + close(12) + +real*8 :: approx,np,nq,nr,ns +logical :: lpq,lrs,lps,lqr + open(unit=12,file='P0tuvx.dat',form='formatted',status='unknown') + do p=1,n_act_orb + np=D0tu(p,p) + do q=1,n_act_orb + lpq=p.eq.q + nq=D0tu(q,q) + do r=1,n_act_orb + lqr=q.eq.r + nr=D0tu(r,r) + do s=1,n_act_orb + lrs=r.eq.s + lps=p.eq.s + approx=0.D0 + if (lpq.and.lrs) then + if (lqr) then +! pppp + approx=0.5D0*np*(np-1.D0) + else +! pprr + approx=0.5D0*np*nr + end if + else + if (lps.and.lqr.and..not.lpq) then +! pqqp + approx=-0.25D0*np*nq + end if + end if + if (abs(P0tuvx(p,q,r,s)).gt.1.D-12) then + write(12,'(4i4,2E20.12)') p,q,r,s,P0tuvx(p,q,r,s),approx + end if + end do + end do + end do + end do + close(12) + + open(unit=12,form='formatted',status='unknown',file='onetrf.tmp') + indx=0 + do q=1,mo_num + do p=q,mo_num + if (abs(onetrf(p,q)).gt.1.D-12) then + write(12,'(2i6,E20.12)') p,q,onetrf(p,q) + indx+=1 + end if + end do + end do + write(6,*) ' wrote ',indx,' mono-electronic integrals' + close(12) + + + open(unit=12,form='formatted',status='unknown',file='bielec_PQxx.tmp') + indx=0 + do p=1,mo_num + do q=p,mo_num + do r=1,n_core_orb+n_act_orb + do s=r,n_core_orb+n_act_orb + if (abs(bielec_PQxxtmp(p,q,r,s)).gt.1.D-12) then + write(12,'(4i8,E20.12)') p,q,r,s,bielec_PQxxtmp(p,q,r,s) + indx+=1 + end if + end do + end do + end do + end do + write(6,*) ' wrote ',indx,' integrals (PQ|xx)' + close(12) + + open(unit=12,form='formatted',status='unknown',file='bielec_PxxQ.tmp') + indx=0 + do p=1,mo_num + do q=1,n_core_orb+n_act_orb + do r=q,n_core_orb+n_act_orb +integer ::s_start + if (q.eq.r) then + s_start=p + else + s_start=1 + end if + do s=s_start,mo_num + if (abs(bielec_PxxQtmp(p,q,r,s)).gt.1.D-12) then + write(12,'(4i8,E20.12)') p,q,r,s,bielec_PxxQtmp(p,q,r,s) + indx+=1 + end if + end do + end do + end do + end do + write(6,*) ' wrote ',indx,' integrals (Px|xQ)' + close(12) + + open(unit=12,form='formatted',status='unknown',file='bielecCI.tmp') + indx=0 + do p=1,n_act_orb + do q=p,n_act_orb + do r=1,n_act_orb + do s=1,mo_num + if (abs(bielecCItmp(p,q,r,s)).gt.1.D-12) then + write(12,'(4i8,E20.12)') p,q,r,s,bielecCItmp(p,q,r,s) + indx+=1 + end if + end do + end do + end do + end do + write(6,*) ' wrote ',indx,' integrals (tu|xP)' + close(12) + + write(6,*) + write(6,*) ' creating new orbitals ' + do i=1,mo_num + write(6,*) ' Orbital No ',i + write(6,'(5F14.6)') (NatOrbsFCI(j,i),j=1,mo_num) + write(6,*) + end do + + mo_label = "MCSCF" + mo_label = "Natural" + do i=1,mo_num + do j=1,ao_num + mo_coef(j,i)=NatOrbsFCI(j,i) + end do + end do + call save_mos + + write(6,*) ' ... done ' + + end + diff --git a/src/casscf/natorb.irp.f b/src/casscf/natorb.irp.f new file mode 100644 index 00000000..a903260c --- /dev/null +++ b/src/casscf/natorb.irp.f @@ -0,0 +1,548 @@ +! -*- F90 -*- +! diagonalize D0tu +! save the diagonal somewhere, in inverse order +! 4-index-transform the 2-particle density matrix over active orbitals +! correct the bielectronic integrals +! correct the monoelectronic integrals +! put integrals on file, as well orbitals, and the density matrices +! + subroutine trf_to_natorb + implicit none + integer :: i,j,k,l,t,u,p,q,pp + real*8 :: eigval(n_act_orb),natorbsCI(n_act_orb,n_act_orb) + real*8 :: d(n_act_orb),d1(n_act_orb),d2(n_act_orb) + + call lapack_diag(eigval,natorbsCI,D0tu,n_act_orb,n_act_orb) + write(6,*) ' found occupation numbers as ' + do i=1,n_act_orb + write(6,*) i,eigval(i) + end do + + if (bavard) then +! + +integer :: nmx +real*8 :: xmx + do i=1,n_act_orb +! largest element of the eigenvector should be positive + xmx=0.D0 + nmx=0 + do j=1,n_act_orb + if (abs(natOrbsCI(j,i)).gt.xmx) then + nmx=j + xmx=abs(natOrbsCI(j,i)) + end if + end do + xmx=sign(1.D0,natOrbsCI(nmx,i)) + do j=1,n_act_orb + natOrbsCI(j,i)*=xmx + end do + + + write(6,*) ' Eigenvector No ',i + write(6,'(5(I3,F12.5))') (j,natOrbsCI(j,i),j=1,n_act_orb) + end do + end if + + do i=1,n_act_orb + do j=1,n_act_orb + D0tu(i,j)=0.D0 + end do +! fill occupation numbers in descending order + D0tu(i,i)=eigval(n_act_orb-i+1) + end do +! +! 4-index transformation of 2part matrices +! +! index per index +! first quarter + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=P0tuvx(q,j,k,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + P0tuvx(p,j,k,l)=d(p) + end do + end do + end do + end do +! 2nd quarter + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=P0tuvx(j,q,k,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + P0tuvx(j,p,k,l)=d(p) + end do + end do + end do + end do +! 3rd quarter + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=P0tuvx(j,k,q,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + P0tuvx(j,k,p,l)=d(p) + end do + end do + end do + end do +! 4th quarter + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=P0tuvx(j,k,l,q)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + P0tuvx(j,k,l,p)=d(p) + end do + end do + end do + end do + write(6,*) ' transformed P0tuvx ' +! +! one-electron integrals +! + do i=1,mo_num + do j=1,mo_num + onetrf(i,j)=mo_one_e_integrals(i,j) + end do + end do +! 1st half-trf + do j=1,mo_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=onetrf(list_act(q),j)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + onetrf(list_act(p),j)=d(p) + end do + end do +! 2nd half-trf + do j=1,mo_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=onetrf(j,list_act(q))*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + onetrf(j,list_act(p))=d(p) + end do + end do + write(6,*) ' transformed onetrf ' +! +! Orbitals +! + do j=1,ao_num + do i=1,mo_num + NatOrbsFCI(j,i)=mo_coef(j,i) + end do + end do + + do j=1,ao_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=NatOrbsFCI(j,list_act(q))*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + NatOrbsFCI(j,list_act(p))=d(p) + end do + end do + write(6,*) ' transformed orbitals ' +! +! now the bielectronic integrals +! +!!$ write(6,*) ' before the transformation ' +!!$integer :: kk,ll,ii,jj +!!$real*8 :: h1,h2,h3 +!!$ do i=1,n_act_orb +!!$ ii=list_act(i) +!!$ do j=1,n_act_orb +!!$ jj=list_act(j) +!!$ do k=1,n_act_orb +!!$ kk=list_act(k) +!!$ do l=1,n_act_orb +!!$ ll=list_act(l) +!!$ h1=bielec_PQxxtmp(ii,jj,k+n_core_orb,l+n_core_orb) +!!$ h2=bielec_PxxQtmp(ii,j+n_core_orb,k+n_core_orb,ll) +!!$ h3=bielecCItmp(i,j,k,ll) +!!$ if ((h1.ne.h2).or.(h1.ne.h3)) then +!!$ write(6,9901) i,j,k,l,h1,h2,h3 +!!$9901 format(' aie ',4i4,3E20.12) +!!$9902 format('correct',4i4,3E20.12) +!!$ else +!!$ write(6,9902) i,j,k,l,h1,h2,h3 +!!$ end if +!!$ end do +!!$ end do +!!$ end do +!!$ end do + + do j=1,mo_num + do k=1,n_core_orb+n_act_orb + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d1(p)=0.D0 + d2(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d1(pp)+=bielec_PQxxtmp(list_act(q),j,k,l)*natorbsCI(q,p) + d2(pp)+=bielec_PxxQtmp(list_act(q),k,l,j)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PQxxtmp(list_act(p),j,k,l)=d1(p) + bielec_PxxQtmp(list_act(p),k,l,j)=d2(p) + end do + end do + end do + end do +! 2nd quarter + do j=1,mo_num + do k=1,n_core_orb+n_act_orb + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d1(p)=0.D0 + d2(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d1(pp)+=bielec_PQxxtmp(j,list_act(q),k,l)*natorbsCI(q,p) + d2(pp)+=bielec_PxxQtmp(j,k,l,list_act(q))*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PQxxtmp(j,list_act(p),k,l)=d1(p) + bielec_PxxQtmp(j,k,l,list_act(p))=d2(p) + end do + end do + end do + end do +! 3rd quarter + do j=1,mo_num + do k=1,mo_num + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d1(p)=0.D0 + d2(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d1(pp)+=bielec_PQxxtmp(j,k,n_core_orb+q,l)*natorbsCI(q,p) + d2(pp)+=bielec_PxxQtmp(j,n_core_orb+q,l,k)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PQxxtmp(j,k,n_core_orb+p,l)=d1(p) + bielec_PxxQtmp(j,n_core_orb+p,l,k)=d2(p) + end do + end do + end do + end do +! 4th quarter + do j=1,mo_num + do k=1,mo_num + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d1(p)=0.D0 + d2(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d1(pp)+=bielec_PQxxtmp(j,k,l,n_core_orb+q)*natorbsCI(q,p) + d2(pp)+=bielec_PxxQtmp(j,l,n_core_orb+q,k)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PQxxtmp(j,k,l,n_core_orb+p)=d1(p) + bielec_PxxQtmp(j,l,n_core_orb+p,k)=d2(p) + end do + end do + end do + end do + write(6,*) ' transformed PQxx and PxxQ ' +! +! and finally the bielecCI integrals +! + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,mo_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielecCItmp(q,j,k,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielecCItmp(p,j,k,l)=d(p) + end do + end do + end do + end do +! 2nd quarter + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,mo_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielecCItmp(j,q,k,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielecCItmp(j,p,k,l)=d(p) + end do + end do + end do + end do +! 3rd quarter + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,mo_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielecCItmp(j,k,q,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielecCItmp(j,k,p,l)=d(p) + end do + end do + end do + end do +! 4th quarter + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielecCItmp(j,k,l,list_act(q))*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielecCItmp(j,k,l,list_act(p))=d(p) + end do + end do + end do + end do + write(6,*) ' transformed tuvP ' +! +! that's all +! +!!$ +!!$! test coherence of the bielectronic integals +!!$! PQxx = PxxQ = tuvP for some of the indices +!!$ write(6,*) ' after the transformation ' +!!$ do i=1,n_act_orb +!!$ ii=list_act(i) +!!$ do j=1,n_act_orb +!!$ jj=list_act(j) +!!$ do k=1,n_act_orb +!!$ kk=list_act(k) +!!$ do l=1,n_act_orb +!!$ ll=list_act(l) +!!$ h1=bielec_PQxxtmp(ii,jj,k+n_core_orb,l+n_core_orb) +!!$ h2=bielec_PxxQtmp(ii,j+n_core_orb,k+n_core_orb,ll) +!!$ h3=bielecCItmp(i,j,k,ll) +!!$ if ((abs(h1-h2).gt.1.D-14).or.(abs(h1-h3).gt.1.D-14)) then +!!$ write(6,9901) i,j,k,l,h1,h1-h2,h1-h3 +!!$ else +!!$ write(6,9902) i,j,k,l,h1,h2,h3 +!!$ end if +!!$ end do +!!$ end do +!!$ end do +!!$ end do + +! we recalculate total energies + write(6,*) + write(6,*) ' recalculating energies after the transformation ' + write(6,*) + write(6,*) + real*8 :: e_one_all + real*8 :: e_two_all + integer :: ii + integer :: jj + integer :: t3 + integer :: tt + integer :: u3 + integer :: uu + integer :: v + integer :: v3 + integer :: vv + integer :: x + integer :: x3 + integer :: xx + + e_one_all=0.D0 + e_two_all=0.D0 + do i=1,n_core_orb + ii=list_core(i) + e_one_all+=2.D0*onetrf(ii,ii) + do j=1,n_core_orb + jj=list_core(j) + e_two_all+=2.D0*bielec_PQxxtmp(ii,ii,j,j)-bielec_PQxxtmp(ii,jj,j,i) + end do + do t=1,n_act_orb + tt=list_act(t) + t3=t+n_core_orb + do u=1,n_act_orb + uu=list_act(u) + u3=u+n_core_orb + e_two_all+=D0tu(t,u)*(2.D0*bielec_PQxxtmp(tt,uu,i,i) & + -bielec_PQxxtmp(tt,ii,i,u3)) + end do + end do + end do + do t=1,n_act_orb + tt=list_act(t) + do u=1,n_act_orb + uu=list_act(u) + e_one_all+=D0tu(t,u)*onetrf(tt,uu) + do v=1,n_act_orb + v3=v+n_core_orb + do x=1,n_act_orb + x3=x+n_core_orb + e_two_all +=P0tuvx(t,u,v,x)*bielec_PQxxtmp(tt,uu,v3,x3) + end do + end do + end do + end do + write(6,*) ' e_one_all = ',e_one_all + write(6,*) ' e_two_all = ',e_two_all + ecore =nuclear_repulsion + ecore_bis=nuclear_repulsion + do i=1,n_core_orb + ii=list_core(i) + ecore +=2.D0*onetrf(ii,ii) + ecore_bis+=2.D0*onetrf(ii,ii) + do j=1,n_core_orb + jj=list_core(j) + ecore +=2.D0*bielec_PQxxtmp(ii,ii,j,j)-bielec_PQxxtmp(ii,jj,j,i) + ecore_bis+=2.D0*bielec_PxxQtmp(ii,i,j,jj)-bielec_PxxQtmp(ii,j,j,ii) + end do + end do + eone =0.D0 + eone_bis=0.D0 + etwo =0.D0 + etwo_bis=0.D0 + etwo_ter=0.D0 + do t=1,n_act_orb + tt=list_act(t) + t3=t+n_core_orb + do u=1,n_act_orb + uu=list_act(u) + u3=u+n_core_orb + eone +=D0tu(t,u)*onetrf(tt,uu) + eone_bis+=D0tu(t,u)*onetrf(tt,uu) + do i=1,n_core_orb + ii=list_core(i) + eone +=D0tu(t,u)*(2.D0*bielec_PQxxtmp(tt,uu,i,i) & + -bielec_PQxxtmp(tt,ii,i,u3)) + eone_bis+=D0tu(t,u)*(2.D0*bielec_PxxQtmp(tt,u3,i,ii) & + -bielec_PxxQtmp(tt,i,i,uu)) + end do + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_orb + do x=1,n_act_orb + xx=list_act(x) + x3=x+n_core_orb +real*8 :: h1,h2,h3 + h1=bielec_PQxxtmp(tt,uu,v3,x3) + h2=bielec_PxxQtmp(tt,u3,v3,xx) + h3=bielecCItmp(t,u,v,xx) + etwo +=P0tuvx(t,u,v,x)*h1 + etwo_bis+=P0tuvx(t,u,v,x)*h2 + etwo_ter+=P0tuvx(t,u,v,x)*h3 + if ((abs(h1-h2).gt.1.D-14).or.(abs(h1-h3).gt.1.D-14)) then + write(6,9901) t,u,v,x,h1,h2,h3 +9901 format('aie: ',4I4,3E20.12) + end if + end do + end do + end do + end do + + write(6,*) ' energy contributions ' + write(6,*) ' core energy = ',ecore,' using PQxx integrals ' + write(6,*) ' core energy (bis) = ',ecore,' using PxxQ integrals ' + write(6,*) ' 1el energy = ',eone ,' using PQxx integrals ' + write(6,*) ' 1el energy (bis) = ',eone ,' using PxxQ integrals ' + write(6,*) ' 2el energy = ',etwo ,' using PQxx integrals ' + write(6,*) ' 2el energy (bis) = ',etwo_bis,' using PxxQ integrals ' + write(6,*) ' 2el energy (ter) = ',etwo_ter,' using tuvP integrals ' + write(6,*) ' ----------------------------------------- ' + write(6,*) ' sum of all = ',eone+etwo+ecore + write(6,*) + + end subroutine trf_to_natorb + + BEGIN_PROVIDER [real*8, onetrf, (mo_num,mo_num)] +&BEGIN_PROVIDER [real*8, NatOrbsFCI, (ao_num,mo_num)] +END_PROVIDER diff --git a/src/casscf/tot_en.irp.f b/src/casscf/tot_en.irp.f new file mode 100644 index 00000000..8734006e --- /dev/null +++ b/src/casscf/tot_en.irp.f @@ -0,0 +1,122 @@ +! -*- F90 -*- + BEGIN_PROVIDER [real*8, etwo] +&BEGIN_PROVIDER [real*8, eone] +&BEGIN_PROVIDER [real*8, eone_bis] +&BEGIN_PROVIDER [real*8, etwo_bis] +&BEGIN_PROVIDER [real*8, etwo_ter] +&BEGIN_PROVIDER [real*8, ecore] +&BEGIN_PROVIDER [real*8, ecore_bis] + implicit none + integer :: t,u,v,x,i,ii,tt,uu,vv,xx,j,jj,t3,u3,v3,x3 +real*8 :: e_one_all,e_two_all + e_one_all=0.D0 + e_two_all=0.D0 + do i=1,n_core_orb + ii=list_core(i) + e_one_all+=2.D0*mo_one_e_integrals(ii,ii) + do j=1,n_core_orb + jj=list_core(j) + e_two_all+=2.D0*bielec_PQxxtmp(ii,ii,j,j)-bielec_PQxxtmp(ii,jj,j,i) + end do + do t=1,n_act_orb + tt=list_act(t) + t3=t+n_core_orb + do u=1,n_act_orb + uu=list_act(u) + u3=u+n_core_orb + e_two_all+=D0tu(t,u)*(2.D0*bielec_PQxxtmp(tt,uu,i,i) & + -bielec_PQxxtmp(tt,ii,i,u3)) + end do + end do + end do + do t=1,n_act_orb + tt=list_act(t) + do u=1,n_act_orb + uu=list_act(u) + e_one_all+=D0tu(t,u)*mo_one_e_integrals(tt,uu) + do v=1,n_act_orb + v3=v+n_core_orb + do x=1,n_act_orb + x3=x+n_core_orb + e_two_all +=P0tuvx(t,u,v,x)*bielec_PQxxtmp(tt,uu,v3,x3) + end do + end do + end do + end do + write(6,*) ' e_one_all = ',e_one_all + write(6,*) ' e_two_all = ',e_two_all + ecore =nuclear_repulsion + ecore_bis=nuclear_repulsion + do i=1,n_core_orb + ii=list_core(i) + ecore +=2.D0*mo_one_e_integrals(ii,ii) + ecore_bis+=2.D0*mo_one_e_integrals(ii,ii) + do j=1,n_core_orb + jj=list_core(j) + ecore +=2.D0*bielec_PQxxtmp(ii,ii,j,j)-bielec_PQxxtmp(ii,jj,j,i) + ecore_bis+=2.D0*bielec_PxxQtmp(ii,i,j,jj)-bielec_PxxQtmp(ii,j,j,ii) + end do + end do + eone =0.D0 + eone_bis=0.D0 + etwo =0.D0 + etwo_bis=0.D0 + etwo_ter=0.D0 + do t=1,n_act_orb + tt=list_act(t) + t3=t+n_core_orb + do u=1,n_act_orb + uu=list_act(u) + u3=u+n_core_orb + eone +=D0tu(t,u)*mo_one_e_integrals(tt,uu) + eone_bis+=D0tu(t,u)*mo_one_e_integrals(tt,uu) + do i=1,n_core_orb + ii=list_core(i) + eone +=D0tu(t,u)*(2.D0*bielec_PQxxtmp(tt,uu,i,i) & + -bielec_PQxxtmp(tt,ii,i,u3)) + eone_bis+=D0tu(t,u)*(2.D0*bielec_PxxQtmp(tt,u3,i,ii) & + -bielec_PxxQtmp(tt,i,i,uu)) + end do + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_orb + do x=1,n_act_orb + xx=list_act(x) + x3=x+n_core_orb +real*8 :: h1,h2,h3 + h1=bielec_PQxxtmp(tt,uu,v3,x3) + h2=bielec_PxxQtmp(tt,u3,v3,xx) + h3=bielecCItmp(t,u,v,xx) + etwo +=P0tuvx(t,u,v,x)*h1 + etwo_bis+=P0tuvx(t,u,v,x)*h2 + etwo_ter+=P0tuvx(t,u,v,x)*h3 + if ((h1.ne.h2).or.(h1.ne.h3)) then + write(6,9901) t,u,v,x,h1,h2,h3 +9901 format('aie: ',4I4,3E20.12) + end if + end do + end do + end do + end do + + write(6,*) ' energy contributions ' + write(6,*) ' core energy = ',ecore,' using PQxx integrals ' + write(6,*) ' core energy (bis) = ',ecore,' using PxxQ integrals ' + write(6,*) ' 1el energy = ',eone ,' using PQxx integrals ' + write(6,*) ' 1el energy (bis) = ',eone ,' using PxxQ integrals ' + write(6,*) ' 2el energy = ',etwo ,' using PQxx integrals ' + write(6,*) ' 2el energy (bis) = ',etwo_bis,' using PxxQ integrals ' + write(6,*) ' 2el energy (ter) = ',etwo_ter,' using tuvP integrals ' + write(6,*) ' ----------------------------------------- ' + write(6,*) ' sum of all = ',eone+etwo+ecore + write(6,*) + write(6,*) ' nuclear (qp) = ',nuclear_repulsion + write(6,*) ' core energy (qp) = ',core_energy + write(6,*) ' 1el energy (qp) = ',psi_energy_h_core(1) + write(6,*) ' 2el energy (qp) = ',psi_energy_two_e(1) + write(6,*) ' nuc + 1 + 2 (qp) = ',nuclear_repulsion+psi_energy_h_core(1)+psi_energy_two_e(1) + write(6,*) ' <0|H|0> (qp) = ',psi_energy_with_nucl_rep(1) + +END_PROVIDER + + From 328ab2dadf856732af82aba1fd5386a3ab3ee909 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 24 Jun 2019 17:03:27 +0200 Subject: [PATCH 06/59] All programs merged. Iterations not working --- src/casscf/bielec.irp.f | 104 ++++++ src/casscf/casscf.irp.f | 17 +- src/casscf/driver_optorb.irp.f | 32 ++ src/casscf/gradient.irp.f | 251 +++++++++++++ src/casscf/hessian.irp.f | 639 +++++++++++++++++++++++++++++++++ src/casscf/mcscf_fock.irp.f | 67 ++++ src/casscf/natorb_casscf.irp.f | 65 ++++ src/casscf/neworbs.irp.f | 222 ++++++++++++ src/casscf/one_ints.irp.f | 26 ++ 9 files changed, 1421 insertions(+), 2 deletions(-) create mode 100644 src/casscf/bielec.irp.f create mode 100644 src/casscf/driver_optorb.irp.f create mode 100644 src/casscf/gradient.irp.f create mode 100644 src/casscf/hessian.irp.f create mode 100644 src/casscf/mcscf_fock.irp.f create mode 100644 src/casscf/natorb_casscf.irp.f create mode 100644 src/casscf/neworbs.irp.f create mode 100644 src/casscf/one_ints.irp.f diff --git a/src/casscf/bielec.irp.f b/src/casscf/bielec.irp.f new file mode 100644 index 00000000..a1ec155d --- /dev/null +++ b/src/casscf/bielec.irp.f @@ -0,0 +1,104 @@ +! -*- F90 -*- + BEGIN_PROVIDER[real*8, bielec_PQxx, (mo_num, mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb)] +&BEGIN_PROVIDER[real*8, bielec_PxxQ, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb, mo_num)] +BEGIN_DOC +! bielec_PQxx : integral (pq|xx) with p,q arbitrary, x core or active +! bielec_PxxQ : integral (px|xq) with p,q arbitrary, x core or active +! indices are unshifted orbital numbers +! all integrals are read from files +END_DOC + implicit none + integer :: i,j,p,q,indx,kk + real*8 :: hhh + logical :: lread + + do i=1,n_core_orb+n_act_orb + do j=1,n_core_orb+n_act_orb + do p=1,mo_num + do q=1,mo_num + bielec_PQxx(p,q,i,j)=0.D0 + bielec_PxxQ(p,i,j,q)=0.D0 + end do + end do + end do + end do + + open(unit=12,form='formatted',status='old',file='bielec_PQxx.tmp') + lread=.true. + indx=0 + do while (lread) + read(12,*,iostat=kk) p,q,i,j,hhh + if (kk.ne.0) then + lread=.false. + else +! stored with p.le.q, i.le.j + bielec_PQxx(p,q,i,j)=hhh + bielec_PQxx(q,p,i,j)=hhh + bielec_PQxx(q,p,j,i)=hhh + bielec_PQxx(p,q,j,i)=hhh + indx+=1 + end if + end do + close(12) + write(6,*) ' read ',indx,' integrals PQxx into core ' + + open(unit=12,form='formatted',status='old',file='bielec_PxxQ.tmp') + lread=.true. + indx=0 + do while (lread) + read(12,*,iostat=kk) p,i,j,q,hhh + if (kk.ne.0) then + lread=.false. + else +! stored with (ip).le.(jq) + bielec_PxxQ(p,i,j,q)=hhh + bielec_PxxQ(q,j,i,p)=hhh + indx+=1 + end if + end do + write(6,*) ' read ',indx,' integrals PxxQ into core ' + close(12) + write(6,*) ' provided integrals (PQ|xx) and (Px|xQ) ' +END_PROVIDER + +BEGIN_PROVIDER[real*8, bielecCI, (n_act_orb,n_act_orb,n_act_orb, mo_num)] +BEGIN_DOC +! bielecCI : integrals (tu|vp) with p arbitrary, tuv active +! index p runs over the whole basis, t,u,v only over the active orbitals +! inegrals read from file +END_DOC + implicit none + integer :: i,j,k,p,t,u,v,kk,indx + real*8 :: hhh + logical :: lread + + write(6,*) ' reading integrals bielecCI ' + + do i=1,n_act_orb + do j=1,n_act_orb + do k=1,n_act_orb + do p=1,mo_num + bielecCI(i,k,j,p)=0.D0 + end do + end do + end do + end do + + open(unit=12,form='formatted',status='old',file='bielecCI.tmp') + lread=.true. + indx=0 + do while (lread) + read(12,*,iostat=kk) i,j,k,p,hhh + if (kk.ne.0) then + lread=.false. + else + bielecCI(i,j,k,p)=hhh + bielecCI(j,i,k,p)=hhh + indx+=1 + end if + end do + write(6,*) ' read ',indx,' integrals (aa|aP) into core ' + close(12) + write(6,*) ' provided integrals (tu|xP) ' +END_PROVIDER + diff --git a/src/casscf/casscf.irp.f b/src/casscf/casscf.irp.f index c08dd032..b55c4c3b 100644 --- a/src/casscf/casscf.irp.f +++ b/src/casscf/casscf.irp.f @@ -10,7 +10,20 @@ end subroutine run implicit none - call run_cipsi - call driver_wdens + double precision :: energy_old, energy + logical :: converged + converged = .False. + + energy = 0.d0 +! do while (.not.converged) + N_det = 1 + TOUCH N_det psi_det psi_coef + call run_cipsi + call driver_wdens + call driver_optorb + energy_old = energy + energy = eone+etwo+ecore + converged = dabs(energy - energy_old) < 1.d-10 +! enddo end diff --git a/src/casscf/driver_optorb.irp.f b/src/casscf/driver_optorb.irp.f new file mode 100644 index 00000000..591c90c9 --- /dev/null +++ b/src/casscf/driver_optorb.irp.f @@ -0,0 +1,32 @@ + subroutine driver_optorb + implicit none + integer :: i,j + + write(6,*) +! write(6,*) ' <0|H|0> (qp) = ',psi_energy_with_nucl_rep(1) + write(6,*) ' energy improvement = ',energy_improvement +! write(6,*) ' new energy = ',psi_energy_with_nucl_rep(1)+energy_improvement + write(6,*) + + write(6,*) + write(6,*) ' creating new orbitals ' + do i=1,mo_num + write(6,*) ' Orbital No ',i + write(6,'(5F14.6)') (NewOrbs(j,i),j=1,mo_num) + write(6,*) + end do + + mo_label = "Natural" + do i=1,mo_num + do j=1,ao_num + mo_coef(j,i)=NewOrbs(j,i) + end do + end do + call save_mos + call map_deinit(mo_integrals_map) + FREE mo_integrals_map mo_coef mo_two_e_integrals_in_map + + write(6,*) + write(6,*) ' ... all done ' + + end diff --git a/src/casscf/gradient.irp.f b/src/casscf/gradient.irp.f new file mode 100644 index 00000000..d35d96ed --- /dev/null +++ b/src/casscf/gradient.irp.f @@ -0,0 +1,251 @@ +! -*- F90 -*- + +use bitmasks ! you need to include the bitmasks_module.f90 features + +BEGIN_PROVIDER [ integer, nMonoEx ] +BEGIN_DOC +! +END_DOC + implicit none + nMonoEx=n_core_orb*n_act_orb+n_core_orb*n_virt_orb+n_act_orb*n_virt_orb + write(6,*) ' nMonoEx = ',nMonoEx +END_PROVIDER + + BEGIN_PROVIDER [integer, excit, (2,nMonoEx)] +&BEGIN_PROVIDER [character*3, excit_class, (nMonoEx)] +BEGIN_DOC +! a list of the orbitals involved in the excitation +END_DOC + + implicit none + integer :: i,t,a,ii,tt,aa,indx + indx=0 + do ii=1,n_core_orb + i=list_core(ii) + do tt=1,n_act_orb + t=list_act(tt) + indx+=1 + excit(1,indx)=i + excit(2,indx)=t + excit_class(indx)='c-a' + end do + end do + + do ii=1,n_core_orb + i=list_core(ii) + do aa=1,n_virt_orb + a=list_virt(aa) + indx+=1 + excit(1,indx)=i + excit(2,indx)=a + excit_class(indx)='c-v' + end do + end do + + do tt=1,n_act_orb + t=list_act(tt) + do aa=1,n_virt_orb + a=list_virt(aa) + indx+=1 + excit(1,indx)=t + excit(2,indx)=a + excit_class(indx)='a-v' + end do + end do + + if (bavard) then + write(6,*) ' Filled the table of the Monoexcitations ' + do indx=1,nMonoEx + write(6,*) ' ex ',indx,' : ',excit(1,indx),' -> ' & + ,excit(2,indx),' ',excit_class(indx) + end do + end if + +END_PROVIDER + +BEGIN_PROVIDER [real*8, gradvec, (nMonoEx)] +BEGIN_DOC +! calculate the orbital gradient by hand, i.e. for +! each determinant I we determine the string E_pq |I> (alpha and beta +! separately) and generate +! sum_I c_I is then the pq component of the orbital +! gradient +! E_pq = a^+_pa_q + a^+_Pa_Q +END_DOC + implicit none + integer :: ii,tt,aa,indx,ihole,ipart,istate + real*8 :: res + + do indx=1,nMonoEx + ihole=excit(1,indx) + ipart=excit(2,indx) + call calc_grad_elem(ihole,ipart,res) + gradvec(indx)=res + end do + +real*8 :: norm_grad + norm_grad=0.d0 + do indx=1,nMonoEx + norm_grad+=gradvec(indx)*gradvec(indx) + end do + norm_grad=sqrt(norm_grad) + write(6,*) + write(6,*) ' Norm of the orbital gradient (via <0|EH|0>) : ', norm_grad + write(6,*) + + +END_PROVIDER + + subroutine calc_grad_elem(ihole,ipart,res) +BEGIN_DOC +! eq 18 of Siegbahn et al, Physica Scripta 1980 +! we calculate 2 , q=hole, p=particle +END_DOC + implicit none + integer :: ihole,ipart,mu,iii,ispin,ierr,nu,istate + real*8 :: res + integer(bit_kind), allocatable :: det_mu(:,:),det_mu_ex(:,:) + real*8 :: i_H_psi_array(N_states),phase + allocate(det_mu(N_int,2)) + allocate(det_mu_ex(N_int,2)) + + res=0.D0 + + do mu=1,n_det +! get the string of the determinant + call det_extract(det_mu,mu,N_int) + do ispin=1,2 +! do the monoexcitation on it + call det_copy(det_mu,det_mu_ex,N_int) + call do_signed_mono_excitation(det_mu,det_mu_ex,nu & + ,ihole,ipart,ispin,phase,ierr) + if (ierr.eq.1) then +! write(6,*) +! write(6,*) ' mu = ',mu +! call print_det(det_mu,N_int) +! write(6,*) ' generated nu = ',nu,' for excitation ',ihole,' -> ',ipart,' ierr = ',ierr,' phase = ',phase,' ispin = ',ispin +! call print_det(det_mu_ex,N_int) + call i_H_psi(det_mu_ex,psi_det,psi_coef,N_int & + ,N_det,N_det,N_states,i_H_psi_array) + do istate=1,N_states + res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase + end do +! write(6,*) ' contribution = ',i_H_psi_array(1)*psi_coef(mu,1)*phase,res + end if + end do + end do + +! state-averaged gradient + res*=2.D0/dble(N_states) + + end subroutine calc_grad_elem + +BEGIN_PROVIDER [real*8, gradvec2, (nMonoEx)] +BEGIN_DOC +! calculate the orbital gradient from density +! matrices and integrals; Siegbahn et al, Phys Scr 1980 +! eqs 14 a,b,c +END_DOC + implicit none + integer :: i,t,a,indx + real*8 :: gradvec_it,gradvec_ia,gradvec_ta + real*8 :: norm_grad + + indx=0 + do i=1,n_core_orb + do t=1,n_act_orb + indx+=1 + gradvec2(indx)=gradvec_it(i,t) + end do + end do + + do i=1,n_core_orb + do a=1,n_virt_orb + indx+=1 + gradvec2(indx)=gradvec_ia(i,a) + end do + end do + + do t=1,n_act_orb + do a=1,n_virt_orb + indx+=1 + gradvec2(indx)=gradvec_ta(t,a) + end do + end do + + norm_grad=0.d0 + do indx=1,nMonoEx + norm_grad+=gradvec2(indx)*gradvec2(indx) + end do + norm_grad=sqrt(norm_grad) + write(6,*) + write(6,*) ' Norm of the orbital gradient (via D, P and integrals): ', norm_grad + write(6,*) + +END_PROVIDER + + real*8 function gradvec_it(i,t) +BEGIN_DOC +! the orbital gradient core -> active +! we assume natural orbitals +END_DOC + implicit none + integer :: i,t + + integer :: ii,tt,v,vv,x,y + integer :: x3,y3 + + ii=list_core(i) + tt=list_act(t) + gradvec_it=2.D0*(Fipq(tt,ii)+Fapq(tt,ii)) + gradvec_it-=occnum(tt)*Fipq(ii,tt) + do v=1,n_act_orb + vv=list_act(v) + do x=1,n_act_orb + x3=x+n_core_orb + do y=1,n_act_orb + y3=y+n_core_orb + gradvec_it-=2.D0*P0tuvx_no(t,v,x,y)*bielec_PQxx(ii,vv,x3,y3) + end do + end do + end do + gradvec_it*=2.D0 + end function gradvec_it + + real*8 function gradvec_ia(i,a) +BEGIN_DOC +! the orbital gradient core -> virtual +END_DOC + implicit none + integer :: i,a,ii,aa + + ii=list_core(i) + aa=list_virt(a) + gradvec_ia=2.D0*(Fipq(aa,ii)+Fapq(aa,ii)) + gradvec_ia*=2.D0 + + end function gradvec_ia + + real*8 function gradvec_ta(t,a) +BEGIN_DOC +! the orbital gradient active -> virtual +! we assume natural orbitals +END_DOC + implicit none + integer :: t,a,tt,aa,v,vv,x,y + + tt=list_act(t) + aa=list_virt(a) + gradvec_ta=0.D0 + gradvec_ta+=occnum(tt)*Fipq(aa,tt) + do v=1,n_act_orb + do x=1,n_act_orb + do y=1,n_act_orb + gradvec_ta+=2.D0*P0tuvx_no(t,v,x,y)*bielecCI(x,y,v,aa) + end do + end do + end do + gradvec_ta*=2.D0 + + end function gradvec_ta + diff --git a/src/casscf/hessian.irp.f b/src/casscf/hessian.irp.f new file mode 100644 index 00000000..4603d11e --- /dev/null +++ b/src/casscf/hessian.irp.f @@ -0,0 +1,639 @@ +! -*- F90 -*- + +use bitmasks ! you need to include the bitmasks_module.f90 features + +BEGIN_PROVIDER [real*8, hessmat, (nMonoEx,nMonoEx)] +BEGIN_DOC +! calculate the orbital hessian 2 +! + + by hand, +! determinant per determinant, as for the gradient +! +! we assume that we have natural active orbitals +END_DOC + implicit none + integer :: indx,ihole,ipart + integer :: jndx,jhole,jpart + character*3 :: iexc,jexc + real*8 :: res + + write(6,*) ' providing Hessian matrix hessmat ' + write(6,*) ' nMonoEx = ',nMonoEx + + do indx=1,nMonoEx + do jndx=1,nMonoEx + hessmat(indx,jndx)=0.D0 + end do + end do + + do indx=1,nMonoEx + ihole=excit(1,indx) + ipart=excit(2,indx) + iexc=excit_class(indx) + do jndx=indx,nMonoEx + jhole=excit(1,jndx) + jpart=excit(2,jndx) + jexc=excit_class(jndx) + call calc_hess_elem(ihole,ipart,jhole,jpart,res) +! write(6,*) ' Hessian ',ihole,'->',ipart & +! ,' (',iexc,')',jhole,'->',jpart,' (',jexc,')',res + hessmat(indx,jndx)=res + hessmat(jndx,indx)=res + end do + end do + +END_PROVIDER + + subroutine calc_hess_elem(ihole,ipart,jhole,jpart,res) +BEGIN_DOC +! eq 19 of Siegbahn et al, Physica Scripta 1980 +! we calculate 2 +! + + +! average over all states is performed. +! no transition between states. +END_DOC + implicit none + integer :: ihole,ipart,ispin,mu,istate + integer :: jhole,jpart,jspin + integer :: mu_pq, mu_pqrs, mu_rs, mu_rspq, nu_rs,nu + real*8 :: res + integer(bit_kind), allocatable :: det_mu(:,:) + integer(bit_kind), allocatable :: det_nu(:,:) + integer(bit_kind), allocatable :: det_mu_pq(:,:) + integer(bit_kind), allocatable :: det_mu_rs(:,:) + integer(bit_kind), allocatable :: det_nu_rs(:,:) + integer(bit_kind), allocatable :: det_mu_pqrs(:,:) + integer(bit_kind), allocatable :: det_mu_rspq(:,:) + real*8 :: i_H_psi_array(N_states),phase,phase2,phase3 + real*8 :: i_H_j_element + allocate(det_mu(N_int,2)) + allocate(det_nu(N_int,2)) + allocate(det_mu_pq(N_int,2)) + allocate(det_mu_rs(N_int,2)) + allocate(det_nu_rs(N_int,2)) + allocate(det_mu_pqrs(N_int,2)) + allocate(det_mu_rspq(N_int,2)) + integer :: mu_pq_possible + integer :: mu_rs_possible + integer :: nu_rs_possible + integer :: mu_pqrs_possible + integer :: mu_rspq_possible + + res=0.D0 + +! the terms <0|E E H |0> + do mu=1,n_det +! get the string of the determinant + call det_extract(det_mu,mu,N_int) + do ispin=1,2 +! do the monoexcitation pq on it + call det_copy(det_mu,det_mu_pq,N_int) + call do_signed_mono_excitation(det_mu,det_mu_pq,mu_pq & + ,ihole,ipart,ispin,phase,mu_pq_possible) + if (mu_pq_possible.eq.1) then +! possible, but not necessarily in the list +! do the second excitation + do jspin=1,2 + call det_copy(det_mu_pq,det_mu_pqrs,N_int) + call do_signed_mono_excitation(det_mu_pq,det_mu_pqrs,mu_pqrs & + ,jhole,jpart,jspin,phase2,mu_pqrs_possible) +! excitation possible + if (mu_pqrs_possible.eq.1) then + call i_H_psi(det_mu_pqrs,psi_det,psi_coef,N_int & + ,N_det,N_det,N_states,i_H_psi_array) + do istate=1,N_states + res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase*phase2 + end do + end if +! try the de-excitation with opposite sign + call det_copy(det_mu_pq,det_mu_pqrs,N_int) + call do_signed_mono_excitation(det_mu_pq,det_mu_pqrs,mu_pqrs & + ,jpart,jhole,jspin,phase2,mu_pqrs_possible) + phase2=-phase2 +! excitation possible + if (mu_pqrs_possible.eq.1) then + call i_H_psi(det_mu_pqrs,psi_det,psi_coef,N_int & + ,N_det,N_det,N_states,i_H_psi_array) + do istate=1,N_states + res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase*phase2 + end do + end if + end do + end if +! exchange the notion of pq and rs +! do the monoexcitation rs on the initial determinant + call det_copy(det_mu,det_mu_rs,N_int) + call do_signed_mono_excitation(det_mu,det_mu_rs,mu_rs & + ,jhole,jpart,ispin,phase2,mu_rs_possible) + if (mu_rs_possible.eq.1) then +! do the second excitation + do jspin=1,2 + call det_copy(det_mu_rs,det_mu_rspq,N_int) + call do_signed_mono_excitation(det_mu_rs,det_mu_rspq,mu_rspq & + ,ihole,ipart,jspin,phase3,mu_rspq_possible) +! excitation possible (of course, the result is outside the CAS) + if (mu_rspq_possible.eq.1) then + call i_H_psi(det_mu_rspq,psi_det,psi_coef,N_int & + ,N_det,N_det,N_states,i_H_psi_array) + do istate=1,N_states + res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase2*phase3 + end do + end if +! we may try the de-excitation, with opposite sign + call det_copy(det_mu_rs,det_mu_rspq,N_int) + call do_signed_mono_excitation(det_mu_rs,det_mu_rspq,mu_rspq & + ,ipart,ihole,jspin,phase3,mu_rspq_possible) + phase3=-phase3 +! excitation possible (of course, the result is outside the CAS) + if (mu_rspq_possible.eq.1) then + call i_H_psi(det_mu_rspq,psi_det,psi_coef,N_int & + ,N_det,N_det,N_states,i_H_psi_array) + do istate=1,N_states + res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase2*phase3 + end do + end if + end do + end if +! +! the operator E H E, we have to do a double loop over the determinants +! we still have the determinant mu_pq and the phase in memory + if (mu_pq_possible.eq.1) then + do nu=1,N_det + call det_extract(det_nu,nu,N_int) + do jspin=1,2 + call det_copy(det_nu,det_nu_rs,N_int) + call do_signed_mono_excitation(det_nu,det_nu_rs,nu_rs & + ,jhole,jpart,jspin,phase2,nu_rs_possible) +! excitation possible ? + if (nu_rs_possible.eq.1) then + call i_H_j(det_mu_pq,det_nu_rs,N_int,i_H_j_element) + do istate=1,N_states + res+=2.D0*i_H_j_element*psi_coef(mu,istate) & + *psi_coef(nu,istate)*phase*phase2 + end do + end if + end do + end do + end if + end do + end do + +! state-averaged Hessian + res*=1.D0/dble(N_states) + + end subroutine calc_hess_elem + +BEGIN_PROVIDER [real*8, hessmat2, (nMonoEx,nMonoEx)] +BEGIN_DOC +! explicit hessian matrix from density matrices and integrals +! of course, this will be used for a direct Davidson procedure later +! we will not store the matrix in real life +! formulas are broken down as functions for the 6 classes of matrix elements +! +END_DOC + implicit none + integer :: i,j,t,u,a,b,indx,jndx,bstart,ustart + + real*8 :: hessmat_itju + real*8 :: hessmat_itja + real*8 :: hessmat_itua + real*8 :: hessmat_iajb + real*8 :: hessmat_iatb + real*8 :: hessmat_taub + + write(6,*) ' providing Hessian matrix hessmat2 ' + write(6,*) ' nMonoEx = ',nMonoEx + + indx=1 + do i=1,n_core_orb + do t=1,n_act_orb + jndx=indx + do j=i,n_core_orb + if (i.eq.j) then + ustart=t + else + ustart=1 + end if + do u=ustart,n_act_orb + hessmat2(indx,jndx)=hessmat_itju(i,t,j,u) + hessmat2(jndx,indx)=hessmat2(indx,jndx) +! write(6,*) ' result I :',i,t,j,u,indx,jndx,hessmat(indx,jndx),hessmat2(indx,jndx) + jndx+=1 + end do + end do + do j=1,n_core_orb + do a=1,n_virt_orb + hessmat2(indx,jndx)=hessmat_itja(i,t,j,a) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + jndx+=1 + end do + end do + do u=1,n_act_orb + do a=1,n_virt_orb + hessmat2(indx,jndx)=hessmat_itua(i,t,u,a) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + jndx+=1 + end do + end do + indx+=1 + end do + end do + + do i=1,n_core_orb + do a=1,n_virt_orb + jndx=indx + do j=i,n_core_orb + if (i.eq.j) then + bstart=a + else + bstart=1 + end if + do b=bstart,n_virt_orb + hessmat2(indx,jndx)=hessmat_iajb(i,a,j,b) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + jndx+=1 + end do + end do + do t=1,n_act_orb + do b=1,n_virt_orb + hessmat2(indx,jndx)=hessmat_iatb(i,a,t,b) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + jndx+=1 + end do + end do + indx+=1 + end do + end do + + do t=1,n_act_orb + do a=1,n_virt_orb + jndx=indx + do u=t,n_act_orb + if (t.eq.u) then + bstart=a + else + bstart=1 + end if + do b=bstart,n_virt_orb + hessmat2(indx,jndx)=hessmat_taub(t,a,u,b) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + jndx+=1 + end do + end do + indx+=1 + end do + end do + +END_PROVIDER + + real*8 function hessmat_itju(i,t,j,u) +BEGIN_DOC +! the orbital hessian for core->act,core->act +! i, t, j, u are list indices, the corresponding orbitals are ii,tt,jj,uu +! +! we assume natural orbitals +END_DOC + implicit none + integer :: i,t,j,u,ii,tt,uu,v,vv,x,xx,y,jj + real*8 :: term,t2 + +! write(6,*) ' hessmat_itju ',i,t,j,u + ii=list_core(i) + tt=list_act(t) + if (i.eq.j) then + if (t.eq.u) then +! diagonal element + term=occnum(tt)*Fipq(ii,ii)+2.D0*(Fipq(tt,tt)+Fapq(tt,tt)) & + -2.D0*(Fipq(ii,ii)+Fapq(ii,ii)) + term+=2.D0*(3.D0*bielec_pxxq(tt,i,i,tt)-bielec_pqxx(tt,tt,i,i)) + term-=2.D0*occnum(tt)*(3.D0*bielec_pxxq(tt,i,i,tt) & + -bielec_pqxx(tt,tt,i,i)) + term-=occnum(tt)*Fipq(tt,tt) + do v=1,n_act_orb + vv=list_act(v) + do x=1,n_act_orb + xx=list_act(x) + term+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx(vv,xx,i,i) & + +(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* & + bielec_pxxq(vv,i,i,xx)) + do y=1,n_act_orb + term-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI(t,v,y,xx) + end do + end do + end do + else +! it/iu, t != u + uu=list_act(u) + term=2.D0*(Fipq(tt,uu)+Fapq(tt,uu)) + term+=2.D0*(4.D0*bielec_PxxQ(tt,i,j,uu)-bielec_PxxQ(uu,i,j,tt) & + -bielec_PQxx(tt,uu,i,j)) + term-=occnum(tt)*Fipq(uu,tt) + term-=(occnum(tt)+occnum(uu)) & + *(3.D0*bielec_PxxQ(tt,i,i,uu)-bielec_PQxx(uu,tt,i,i)) + do v=1,n_act_orb + vv=list_act(v) +! term-=D0tu(u,v)*Fipq(tt,vv) ! published, but inverting t and u seems more correct + do x=1,n_act_orb + xx=list_act(x) + term+=2.D0*(P0tuvx_no(u,t,v,x)*bielec_pqxx(vv,xx,i,i) & + +(P0tuvx_no(u,x,v,t)+P0tuvx_no(u,x,t,v)) & + *bielec_pxxq(vv,i,i,xx)) + do y=1,n_act_orb + term-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI(u,v,y,xx) + end do + end do + end do +!!! write(6,*) ' direct diff ',i,t,j,u,term,term2 +!!! term=term2 + end if + else +! it/ju + jj=list_core(j) + uu=list_act(u) + if (t.eq.u) then + term=occnum(tt)*Fipq(ii,jj) + term-=2.D0*(Fipq(ii,jj)+Fapq(ii,jj)) + else + term=0.D0 + end if + term+=2.D0*(4.D0*bielec_PxxQ(tt,i,j,uu)-bielec_PxxQ(uu,i,j,tt) & + -bielec_PQxx(tt,uu,i,j)) + term-=(occnum(tt)+occnum(uu))* & + (4.D0*bielec_PxxQ(tt,i,j,uu)-bielec_PxxQ(uu,i,j,tt) & + -bielec_PQxx(uu,tt,i,j)) + do v=1,n_act_orb + vv=list_act(v) + do x=1,n_act_orb + xx=list_act(x) + term+=2.D0*(P0tuvx_no(u,t,v,x)*bielec_pqxx(vv,xx,i,j) & + +(P0tuvx_no(u,x,v,t)+P0tuvx_no(u,x,t,v)) & + *bielec_pxxq(vv,i,j,xx)) + end do + end do + end if + + term*=2.D0 + hessmat_itju=term + + end function hessmat_itju + + real*8 function hessmat_itja(i,t,j,a) +BEGIN_DOC +! the orbital hessian for core->act,core->virt +END_DOC + implicit none + integer :: i,t,j,a,ii,tt,jj,aa,v,vv,x,y + real*8 :: term + +! write(6,*) ' hessmat_itja ',i,t,j,a +! it/ja + ii=list_core(i) + tt=list_act(t) + jj=list_core(j) + aa=list_virt(a) + term=2.D0*(4.D0*bielec_pxxq(aa,j,i,tt) & + -bielec_pqxx(aa,tt,i,j) -bielec_pxxq(aa,i,j,tt)) + term-=occnum(tt)*(4.D0*bielec_pxxq(aa,j,i,tt) & + -bielec_pqxx(aa,tt,i,j) -bielec_pxxq(aa,i,j,tt)) + if (i.eq.j) then + term+=2.D0*(Fipq(aa,tt)+Fapq(aa,tt)) + term-=0.5D0*occnum(tt)*Fipq(aa,tt) + do v=1,n_act_orb + do x=1,n_act_orb + do y=1,n_act_orb + term-=P0tuvx_no(t,v,x,y)*bielecCI(x,y,v,aa) + end do + end do + end do + end if + term*=2.D0 + hessmat_itja=term + + end function hessmat_itja + + real*8 function hessmat_itua(i,t,u,a) +BEGIN_DOC +! the orbital hessian for core->act,act->virt +END_DOC + implicit none + integer :: i,t,u,a,ii,tt,uu,aa,v,vv,x,xx,u3,t3,v3 + real*8 :: term + +! write(6,*) ' hessmat_itua ',i,t,u,a + ii=list_core(i) + tt=list_act(t) + t3=t+n_core_orb + uu=list_act(u) + u3=u+n_core_orb + aa=list_virt(a) + if (t.eq.u) then + term=-occnum(tt)*Fipq(aa,ii) + else + term=0.D0 + end if + term-=occnum(uu)*(bielec_pqxx(aa,ii,t3,u3)-4.D0*bielec_pqxx(aa,uu,t3,i) & + +bielec_pxxq(aa,t3,u3,ii)) + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_orb + do x=1,n_act_orb +integer :: x3 + xx=list_act(x) + x3=x+n_core_orb + term-=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx(aa,ii,v3,x3) & + +(P0tuvx_no(t,v,u,x)+P0tuvx_no(t,v,x,u)) & + *bielec_pqxx(aa,xx,v3,i)) + end do + end do + if (t.eq.u) then + term+=Fipq(aa,ii)+Fapq(aa,ii) + end if + term*=2.D0 + hessmat_itua=term + + end function hessmat_itua + + real*8 function hessmat_iajb(i,a,j,b) +BEGIN_DOC +! the orbital hessian for core->virt,core->virt +END_DOC + implicit none + integer :: i,a,j,b,ii,aa,jj,bb + real*8 :: term +! write(6,*) ' hessmat_iajb ',i,a,j,b + + ii=list_core(i) + aa=list_virt(a) + if (i.eq.j) then + if (a.eq.b) then +! ia/ia + term=2.D0*(Fipq(aa,aa)+Fapq(aa,aa)-Fipq(ii,ii)-Fapq(ii,ii)) + term+=2.D0*(3.D0*bielec_pxxq(aa,i,i,aa)-bielec_pqxx(aa,aa,i,i)) + else + bb=list_virt(b) +! ia/ib + term=2.D0*(Fipq(aa,bb)+Fapq(aa,bb)) + term+=2.D0*(3.D0*bielec_pxxq(aa,i,i,bb)-bielec_pqxx(aa,bb,i,i)) + end if + else +! ia/jb + jj=list_core(j) + bb=list_virt(b) + term=2.D0*(4.D0*bielec_pxxq(aa,i,j,bb)-bielec_pqxx(aa,bb,i,j) & + -bielec_pxxq(aa,j,i,bb)) + if (a.eq.b) then + term-=2.D0*(Fipq(ii,jj)+Fapq(ii,jj)) + end if + end if + term*=2.D0 + hessmat_iajb=term + + end function hessmat_iajb + + real*8 function hessmat_iatb(i,a,t,b) +BEGIN_DOC +! the orbital hessian for core->virt,act->virt +END_DOC + implicit none + integer :: i,a,t,b,ii,aa,tt,bb,v,vv,x,y,v3,t3 + real*8 :: term + +! write(6,*) ' hessmat_iatb ',i,a,t,b + ii=list_core(i) + aa=list_virt(a) + tt=list_act(t) + bb=list_virt(b) + t3=t+n_core_orb + term=occnum(tt)*(4.D0*bielec_pxxq(aa,i,t3,bb)-bielec_pxxq(aa,t3,i,bb) & + -bielec_pqxx(aa,bb,i,t3)) + if (a.eq.b) then + term-=Fipq(tt,ii)+Fapq(tt,ii) + term-=0.5D0*occnum(tt)*Fipq(tt,ii) + do v=1,n_act_orb + do x=1,n_act_orb + do y=1,n_act_orb + term-=P0tuvx_no(t,v,x,y)*bielecCI(x,y,v,ii) + end do + end do + end do + end if + term*=2.D0 + hessmat_iatb=term + + end function hessmat_iatb + + real*8 function hessmat_taub(t,a,u,b) +BEGIN_DOC +! the orbital hessian for act->virt,act->virt +END_DOC + implicit none + integer :: t,a,u,b,tt,aa,uu,bb,v,vv,x,xx,y + integer :: v3,x3 + real*8 :: term,t1,t2,t3 + + tt=list_act(t) + aa=list_virt(a) + if (t.eq.u) then + if (a.eq.b) then +! ta/ta + t1=occnum(tt)*Fipq(aa,aa) + t2=0.D0 + t3=0.D0 + t1-=occnum(tt)*Fipq(tt,tt) + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_orb + do x=1,n_act_orb + xx=list_act(x) + x3=x+n_core_orb + t2+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx(aa,aa,v3,x3) & + +(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* & + bielec_pxxq(aa,x3,v3,aa)) + do y=1,n_act_orb + t3-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI(t,v,y,xx) + end do + end do + end do + term=t1+t2+t3 +! write(6,*) ' Hess taub ',t,a,t1,t2,t3 + else + bb=list_virt(b) +! ta/tb b/=a + term=occnum(tt)*Fipq(aa,bb) + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_orb + do x=1,n_act_orb + xx=list_act(x) + x3=x+n_core_orb + term+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx(aa,bb,v3,x3) & + +(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v)) & + *bielec_pxxq(aa,x3,v3,bb)) + end do + end do + end if + else +! ta/ub t/=u + uu=list_act(u) + bb=list_virt(b) + term=0.D0 + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_orb + do x=1,n_act_orb + xx=list_act(x) + x3=x+n_core_orb + term+=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx(aa,bb,v3,x3) & + +(P0tuvx_no(t,x,v,u)+P0tuvx_no(t,x,u,v)) & + *bielec_pxxq(aa,x3,v3,bb)) + end do + end do + if (a.eq.b) then + term-=0.5D0*(occnum(tt)*Fipq(uu,tt)+occnum(uu)*Fipq(tt,uu)) + do v=1,n_act_orb + do x=1,n_act_orb + do y=1,n_act_orb + term-=P0tuvx_no(t,v,x,y)*bielecCI(x,y,v,uu) + term-=P0tuvx_no(u,v,x,y)*bielecCI(x,y,v,tt) + end do + end do + end do + end if + + end if + + term*=2.D0 + hessmat_taub=term + + end function hessmat_taub + +BEGIN_PROVIDER [real*8, hessdiag, (nMonoEx)] +BEGIN_DOC +! the diagonal of the Hessian, needed for the Davidson procedure +END_DOC + implicit none + integer :: i,t,a,indx + real*8 :: hessmat_itju,hessmat_iajb,hessmat_taub + + indx=0 + do i=1,n_core_orb + do t=1,n_act_orb + indx+=1 + hessdiag(indx)=hessmat_itju(i,t,i,t) + end do + end do + + do i=1,n_core_orb + do a=1,n_virt_orb + indx+=1 + hessdiag(indx)=hessmat_iajb(i,a,i,a) + end do + end do + + do t=1,n_act_orb + do a=1,n_virt_orb + indx+=1 + hessdiag(indx)=hessmat_taub(t,a,t,a) + end do + end do + +END_PROVIDER diff --git a/src/casscf/mcscf_fock.irp.f b/src/casscf/mcscf_fock.irp.f new file mode 100644 index 00000000..301b1418 --- /dev/null +++ b/src/casscf/mcscf_fock.irp.f @@ -0,0 +1,67 @@ +! -*- F90 -*- + BEGIN_PROVIDER [real*8, Fipq, (mo_num,mo_num) ] +&BEGIN_PROVIDER [real*8, Fapq, (mo_num,mo_num) ] +BEGIN_DOC +! the inactive and the active Fock matrices, in molecular +! orbitals +! we create them in MOs, quite expensive +! +! for an implementation in AOs we need first the natural orbitals +! for forming an active density matrix in AOs +! +END_DOC + implicit none + double precision, allocatable :: integrals_array1(:,:) + double precision, allocatable :: integrals_array2(:,:) + integer :: p,q,k,kk,t,tt,u,uu + allocate(integrals_array1(mo_num,mo_num)) + allocate(integrals_array2(mo_num,mo_num)) + + do p=1,mo_num + do q=1,mo_num + Fipq(p,q)=one_ints(p,q) + Fapq(p,q)=0.D0 + end do + end do + +! the inactive Fock matrix + do k=1,n_core_orb + kk=list_core(k) + do p=1,mo_num + do q=1,mo_num + Fipq(p,q)+=2.D0*bielec_pqxx(p,q,k,k) -bielec_pxxq(p,k,k,q) + end do + end do + end do + +! the active Fock matrix, D0tu is diagonal + do t=1,n_act_orb + tt=list_act(t) + do p=1,mo_num + do q=1,mo_num + Fapq(p,q)+=occnum(tt) & + *(bielec_pqxx(p,q,tt,tt)-0.5D0*bielec_pxxq(p,tt,tt,q)) + end do + end do + end do + +if (bavard) then +integer :: i + write(6,*) + write(6,*) ' the effective Fock matrix over MOs' + write(6,*) + + write(6,*) + write(6,*) ' the diagonal of the inactive effective Fock matrix ' + write(6,'(5(i3,F12.5))') (i,Fipq(i,i),i=1,mo_num) + write(6,*) + write(6,*) + write(6,*) ' the diagonal of the active Fock matrix ' + write(6,'(5(i3,F12.5))') (i,Fapq(i,i),i=1,mo_num) + write(6,*) +end if + + +END_PROVIDER + + diff --git a/src/casscf/natorb_casscf.irp.f b/src/casscf/natorb_casscf.irp.f new file mode 100644 index 00000000..0a818a34 --- /dev/null +++ b/src/casscf/natorb_casscf.irp.f @@ -0,0 +1,65 @@ +! -*- F90 -*- +BEGIN_PROVIDER [real*8, occnum, (mo_num)] + implicit none + integer :: i,kk,j + logical :: lread + real*8 :: rdum + do i=1,mo_num + occnum(i)=0.D0 + end do + do i=1,n_core_orb + occnum(list_core(i))=2.D0 + end do + + open(unit=12,file='D0tu.dat',form='formatted',status='old') + lread=.true. + do while (lread) + read(12,*,iostat=kk) i,j,rdum + if (kk.ne.0) then + lread=.false. + else + if (i.eq.j) then + occnum(list_act(i))=rdum + else + write(6,*) ' WARNING - no natural orbitals !' + write(6,*) i,j,rdum + end if + end if + end do + close(12) + write(6,*) ' read occupation numbers ' + do i=1,mo_num + write(6,*) i,occnum(i) + end do + +END_PROVIDER + +BEGIN_PROVIDER [real*8, P0tuvx_no, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + implicit none + integer :: i,j,k,l,kk + real*8 :: rdum + logical :: lread + + do i=1,n_act_orb + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,n_act_orb + P0tuvx_no(l,k,j,i)=0.D0 + end do + end do + end do + end do + + open(unit=12,file='P0tuvx.dat',form='formatted',status='old') + lread=.true. + do while (lread) + read(12,*,iostat=kk) i,j,k,l,rdum + if (kk.ne.0) then + lread=.false. + else + P0tuvx_no(i,j,k,l)=rdum + end if + end do + close(12) + write(6,*) ' read the 2-particle density matrix ' +END_PROVIDER diff --git a/src/casscf/neworbs.irp.f b/src/casscf/neworbs.irp.f new file mode 100644 index 00000000..6d63a86e --- /dev/null +++ b/src/casscf/neworbs.irp.f @@ -0,0 +1,222 @@ +! -*- F90 -*- +BEGIN_PROVIDER [real*8, SXmatrix, (nMonoEx+1,nMonoEx+1)] + implicit none + integer :: i,j + do i=1,nMonoEx+1 + do j=1,nMonoEx+1 + SXmatrix(i,j)=0.D0 + end do + end do + + do i=1,nMonoEx + SXmatrix(1,i+1)=gradvec2(i) + SXmatrix(1+i,1)=gradvec2(i) + end do + + do i=1,nMonoEx + do j=1,nMonoEx + SXmatrix(i+1,j+1)=hessmat2(i,j) + SXmatrix(j+1,i+1)=hessmat2(i,j) + end do + end do + + if (bavard) then + do i=2,nMonoEx+1 + write(6,*) ' diagonal of the Hessian : ',i,hessmat2(i,i) + end do + end if + + +END_PROVIDER + + BEGIN_PROVIDER [real*8, SXeigenvec, (nMonoEx+1,nMonoEx+1)] +&BEGIN_PROVIDER [real*8, SXeigenval, (nMonoEx+1)] + END_PROVIDER + + BEGIN_PROVIDER [real*8, SXvector, (nMonoEx+1)] +&BEGIN_PROVIDER [real*8, energy_improvement] + implicit none + integer :: ierr,matz,i + real*8 :: c0 + + call lapack_diag(SXeigenval,SXeigenvec,SXmatrix,nMonoEx+1,nMonoEx+1) + write(6,*) ' SXdiag : lowest 5 eigenvalues ' + write(6,*) ' 1 - ',SXeigenval(1),SXeigenvec(1,1) + write(6,*) ' 2 - ',SXeigenval(2),SXeigenvec(1,2) + write(6,*) ' 3 - ',SXeigenval(3),SXeigenvec(1,3) + write(6,*) ' 4 - ',SXeigenval(4),SXeigenvec(1,4) + write(6,*) ' 5 - ',SXeigenval(5),SXeigenvec(1,5) + write(6,*) + write(6,*) ' SXdiag : lowest eigenvalue = ',SXeigenval(1) + energy_improvement = SXeigenval(1) + +integer :: best_vector +real*8 :: best_overlap + best_overlap=0.D0 + do i=1,nMonoEx+1 + if (SXeigenval(i).lt.0.D0) then + if (abs(SXeigenvec(1,i)).gt.best_overlap) then + best_overlap=abs(SXeigenvec(1,i)) + best_vector=i + end if + end if + end do + + write(6,*) ' SXdiag : eigenvalue for best overlap with ' + write(6,*) ' previous orbitals = ',SXeigenval(best_vector) + energy_improvement = SXeigenval(best_vector) + + c0=SXeigenvec(1,best_vector) + write(6,*) ' weight of the 1st element ',c0 + do i=1,nMonoEx+1 + SXvector(i)=SXeigenvec(i,best_vector)/c0 +! write(6,*) ' component No ',i,' : ',SXvector(i) + end do + +END_PROVIDER + + +BEGIN_PROVIDER [real*8, NewOrbs, (ao_num,mo_num) ] + implicit none + integer :: i,j,ialph + +! form the exponential of the Orbital rotations + call get_orbrotmat +! form the new orbitals + do i=1,ao_num + do j=1,mo_num + NewOrbs(i,j)=0.D0 + end do + end do + + do ialph=1,ao_num + do i=1,mo_num + wrkline(i)=mo_coef(ialph,i) + end do + do i=1,mo_num + do j=1,mo_num + NewOrbs(ialph,i)+=Umat(i,j)*wrkline(j) + end do + end do + end do + +END_PROVIDER + + BEGIN_PROVIDER [real*8, Tpotmat, (mo_num,mo_num) ] +&BEGIN_PROVIDER [real*8, Umat, (mo_num,mo_num) ] +&BEGIN_PROVIDER [real*8, wrkline, (mo_num) ] +&BEGIN_PROVIDER [real*8, Tmat, (mo_num,mo_num) ] +END_PROVIDER + + subroutine get_orbrotmat + implicit none + integer :: i,j,indx,k,iter,t,a,ii,tt,aa + real*8 :: sum + logical :: converged + + +! the orbital rotation matrix T + do i=1,mo_num + do j=1,mo_num + Tmat(i,j)=0.D0 + Umat(i,j)=0.D0 + Tpotmat(i,j)=0.D0 + end do + Tpotmat(i,i)=1.D0 + end do + + indx=1 + do i=1,n_core_orb + ii=list_core(i) + do t=1,n_act_orb + tt=list_act(t) + indx+=1 + Tmat(ii,tt)= SXvector(indx) + Tmat(tt,ii)=-SXvector(indx) + end do + end do + do i=1,n_core_orb + ii=list_core(i) + do a=1,n_virt_orb + aa=list_virt(a) + indx+=1 + Tmat(ii,aa)= SXvector(indx) + Tmat(aa,ii)=-SXvector(indx) + end do + end do + do t=1,n_act_orb + tt=list_act(t) + do a=1,n_virt_orb + aa=list_virt(a) + indx+=1 + Tmat(tt,aa)= SXvector(indx) + Tmat(aa,tt)=-SXvector(indx) + end do + end do + + write(6,*) ' the T matrix ' + do indx=1,nMonoEx + i=excit(1,indx) + j=excit(2,indx) +! if (abs(Tmat(i,j)).gt.1.D0) then +! write(6,*) ' setting matrix element ',i,j,' of ',Tmat(i,j),' to ' & +! , sign(1.D0,Tmat(i,j)) +! Tmat(i,j)=sign(1.D0,Tmat(i,j)) +! Tmat(j,i)=-Tmat(i,j) +! end if + if (abs(Tmat(i,j)).gt.1.D-9) write(6,9901) i,j,excit_class(indx),Tmat(i,j) + 9901 format(' ',i4,' -> ',i4,' (',A3,') : ',E14.6) + end do + + write(6,*) + write(6,*) ' forming the matrix exponential ' + write(6,*) +! form the exponential + iter=0 + converged=.false. + do while (.not.converged) + iter+=1 +! add the next term + do i=1,mo_num + do j=1,mo_num + Umat(i,j)+=Tpotmat(i,j) + end do + end do +! next power of T, we multiply Tpotmat with Tmat/iter + do i=1,mo_num + do j=1,mo_num + wrkline(j)=Tpotmat(i,j)/dble(iter) + Tpotmat(i,j)=0.D0 + end do + do j=1,mo_num + do k=1,mo_num + Tpotmat(i,j)+=wrkline(k)*Tmat(k,j) + end do + end do + end do +! Convergence test + sum=0.D0 + do i=1,mo_num + do j=1,mo_num + sum+=abs(Tpotmat(i,j)) + end do + end do + write(6,*) ' Iteration No ',iter,' Sum = ',sum + if (sum.lt.1.D-6) then + converged=.true. + end if + if (iter.ge.NItExpMax) then + stop ' no convergence ' + end if + end do + write(6,*) + write(6,*) ' Converged ! ' + write(6,*) + + end subroutine get_orbrotmat + +BEGIN_PROVIDER [integer, NItExpMax] + NItExpMax=100 +END_PROVIDER + + diff --git a/src/casscf/one_ints.irp.f b/src/casscf/one_ints.irp.f new file mode 100644 index 00000000..a802f644 --- /dev/null +++ b/src/casscf/one_ints.irp.f @@ -0,0 +1,26 @@ +! -*- F90 -*- +BEGIN_PROVIDER [real*8, one_ints, (mo_num,mo_num)] + implicit none + integer :: i,j,kk + logical :: lread + real*8 :: rdum + do i=1,mo_num + do j=1,mo_num + one_ints(i,j)=0.D0 + end do + end do + open(unit=12,file='onetrf.tmp',status='old',form='formatted') + lread=.true. + do while (lread) + read(12,*,iostat=kk) i,j,rdum + if (kk.ne.0) then + lread=.false. + else + one_ints(i,j)=rdum + one_ints(j,i)=rdum + end if + end do + close(12) + write(6,*) ' read MCSCF natural one-electron integrals ' +END_PROVIDER + From 26be853c18189096dea671da1766724540f0a859 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 25 Jun 2019 16:46:14 +0200 Subject: [PATCH 07/59] Cleaning --- src/casscf/bielec.irp.f | 237 ++++--- src/casscf/bielec_create.irp.f | 118 ---- src/casscf/bielec_natorb.irp.f | 273 ++++++++ src/casscf/densities.irp.f | 377 +++++----- src/casscf/det_manip.irp.f | 249 ++++--- src/casscf/driver_wdens.irp.f | 104 +-- src/casscf/gradient.irp.f | 460 ++++++------ src/casscf/hessian.irp.f | 1204 ++++++++++++++++---------------- src/casscf/mcscf_fock.irp.f | 141 ++-- src/casscf/natorb.irp.f | 915 ++++++++++-------------- src/casscf/natorb_casscf.irp.f | 65 -- src/casscf/tot_en.irp.f | 203 +++--- 12 files changed, 2126 insertions(+), 2220 deletions(-) delete mode 100644 src/casscf/bielec_create.irp.f create mode 100644 src/casscf/bielec_natorb.irp.f delete mode 100644 src/casscf/natorb_casscf.irp.f diff --git a/src/casscf/bielec.irp.f b/src/casscf/bielec.irp.f index a1ec155d..9bb953f8 100644 --- a/src/casscf/bielec.irp.f +++ b/src/casscf/bielec.irp.f @@ -1,104 +1,151 @@ -! -*- F90 -*- - BEGIN_PROVIDER[real*8, bielec_PQxx, (mo_num, mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb)] -&BEGIN_PROVIDER[real*8, bielec_PxxQ, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb, mo_num)] -BEGIN_DOC -! bielec_PQxx : integral (pq|xx) with p,q arbitrary, x core or active -! bielec_PxxQ : integral (px|xq) with p,q arbitrary, x core or active -! indices are unshifted orbital numbers -! all integrals are read from files -END_DOC - implicit none - integer :: i,j,p,q,indx,kk - real*8 :: hhh - logical :: lread + BEGIN_PROVIDER [real*8, bielec_PQxx, (mo_num, mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb)] + BEGIN_DOC + ! bielec_PQxx : integral (pq|xx) with p,q arbitrary, x core or active + ! indices are unshifted orbital numbers + END_DOC + implicit none + integer :: i,j,ii,jj,p,q,i3,j3,t3,v3 + double precision, allocatable :: integrals_array(:,:) + real*8 :: mo_two_e_integral + + allocate(integrals_array(mo_num,mo_num)) + + bielec_PQxx = 0.d0 + + do i=1,n_core_orb + ii=list_core(i) + do j=i,n_core_orb + jj=list_core(j) + call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array,mo_integrals_map) + do p=1,mo_num + do q=1,mo_num + bielec_PQxx(p,q,i,j)=integrals_array(p,q) + bielec_PQxx(p,q,j,i)=integrals_array(p,q) + end do + end do + end do + do j=1,n_act_orb + jj=list_act(j) + j3=j+n_core_orb + call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array,mo_integrals_map) + do p=1,mo_num + do q=1,mo_num + bielec_PQxx(p,q,i,j3)=integrals_array(p,q) + bielec_PQxx(p,q,j3,i)=integrals_array(p,q) + end do + end do + end do + end do - do i=1,n_core_orb+n_act_orb - do j=1,n_core_orb+n_act_orb - do p=1,mo_num - do q=1,mo_num - bielec_PQxx(p,q,i,j)=0.D0 - bielec_PxxQ(p,i,j,q)=0.D0 - end do - end do - end do - end do - open(unit=12,form='formatted',status='old',file='bielec_PQxx.tmp') - lread=.true. - indx=0 - do while (lread) - read(12,*,iostat=kk) p,q,i,j,hhh - if (kk.ne.0) then - lread=.false. - else -! stored with p.le.q, i.le.j - bielec_PQxx(p,q,i,j)=hhh - bielec_PQxx(q,p,i,j)=hhh - bielec_PQxx(q,p,j,i)=hhh - bielec_PQxx(p,q,j,i)=hhh - indx+=1 - end if - end do - close(12) - write(6,*) ' read ',indx,' integrals PQxx into core ' - - open(unit=12,form='formatted',status='old',file='bielec_PxxQ.tmp') - lread=.true. - indx=0 - do while (lread) - read(12,*,iostat=kk) p,i,j,q,hhh - if (kk.ne.0) then - lread=.false. - else -! stored with (ip).le.(jq) - bielec_PxxQ(p,i,j,q)=hhh - bielec_PxxQ(q,j,i,p)=hhh - indx+=1 - end if - end do - write(6,*) ' read ',indx,' integrals PxxQ into core ' - close(12) - write(6,*) ' provided integrals (PQ|xx) and (Px|xQ) ' + ! (ij|pq) + do i=1,n_act_orb + ii=list_act(i) + i3=i+n_core_orb + do j=i,n_act_orb + jj=list_act(j) + j3=j+n_core_orb + call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array,mo_integrals_map) + do p=1,mo_num + do q=1,mo_num + bielec_PQxx(p,q,i3,j3)=integrals_array(p,q) + bielec_PQxx(p,q,j3,i3)=integrals_array(p,q) + end do + end do + end do + end do + + write(6,*) ' provided integrals (PQ|xx) ' END_PROVIDER -BEGIN_PROVIDER[real*8, bielecCI, (n_act_orb,n_act_orb,n_act_orb, mo_num)] -BEGIN_DOC -! bielecCI : integrals (tu|vp) with p arbitrary, tuv active -! index p runs over the whole basis, t,u,v only over the active orbitals -! inegrals read from file -END_DOC - implicit none - integer :: i,j,k,p,t,u,v,kk,indx - real*8 :: hhh - logical :: lread - write(6,*) ' reading integrals bielecCI ' - do i=1,n_act_orb - do j=1,n_act_orb - do k=1,n_act_orb - do p=1,mo_num - bielecCI(i,k,j,p)=0.D0 - end do - end do - end do - end do +BEGIN_PROVIDER [real*8, bielec_PxxQ, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb, mo_num)] + BEGIN_DOC + ! bielec_PxxQ : integral (px|xq) with p,q arbitrary, x core or active + ! indices are unshifted orbital numbers + END_DOC + implicit none + integer :: i,j,ii,jj,p,q,i3,j3,t3,v3 + double precision, allocatable :: integrals_array(:,:) + real*8 :: mo_two_e_integral + + allocate(integrals_array(mo_num,mo_num)) + + bielec_PxxQ = 0.d0 + + do i=1,n_core_orb + ii=list_core(i) + do j=i,n_core_orb + jj=list_core(j) + call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array,mo_integrals_map) + do p=1,mo_num + do q=1,mo_num + bielec_PxxQ(p,i,j,q)=integrals_array(p,q) + bielec_PxxQ(p,j,i,q)=integrals_array(q,p) + end do + end do + end do + do j=1,n_act_orb + jj=list_act(j) + j3=j+n_core_orb + call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array,mo_integrals_map) + do p=1,mo_num + do q=1,mo_num + bielec_PxxQ(p,i,j3,q)=integrals_array(p,q) + bielec_PxxQ(p,j3,i,q)=integrals_array(q,p) + end do + end do + end do + end do - open(unit=12,form='formatted',status='old',file='bielecCI.tmp') - lread=.true. - indx=0 - do while (lread) - read(12,*,iostat=kk) i,j,k,p,hhh - if (kk.ne.0) then - lread=.false. - else - bielecCI(i,j,k,p)=hhh - bielecCI(j,i,k,p)=hhh - indx+=1 - end if - end do - write(6,*) ' read ',indx,' integrals (aa|aP) into core ' - close(12) - write(6,*) ' provided integrals (tu|xP) ' + + ! (ip|qj) + do i=1,n_act_orb + ii=list_act(i) + i3=i+n_core_orb + do j=i,n_act_orb + jj=list_act(j) + j3=j+n_core_orb + call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array,mo_integrals_map) + do p=1,mo_num + do q=1,mo_num + bielec_PxxQ(p,i3,j3,q)=integrals_array(p,q) + bielec_PxxQ(p,j3,i3,q)=integrals_array(q,p) + end do + end do + end do + end do + write(6,*) ' provided integrals (Px|xQ) ' +END_PROVIDER + + +BEGIN_PROVIDER [real*8, bielecCI, (n_act_orb,n_act_orb,n_act_orb, mo_num)] + BEGIN_DOC + ! bielecCI : integrals (tu|vp) with p arbitrary, tuv active + ! index p runs over the whole basis, t,u,v only over the active orbitals + END_DOC + implicit none + integer :: i,j,k,p,t,u,v + double precision, allocatable :: integrals_array(:) + real*8 :: mo_two_e_integral + + allocate(integrals_array(mo_num)) + + do i=1,n_act_orb + t=list_act(i) + do j=1,n_act_orb + u=list_act(j) + do k=1,n_act_orb + v=list_act(k) + ! (tu|vp) + call get_mo_two_e_integrals(t,u,v,mo_num,integrals_array,mo_integrals_map) + do p=1,mo_num + bielecCI(i,k,j,p)=integrals_array(p) + end do + end do + end do + end do + write(6,*) ' provided integrals (tu|xP) ' END_PROVIDER diff --git a/src/casscf/bielec_create.irp.f b/src/casscf/bielec_create.irp.f deleted file mode 100644 index 7e6d16c8..00000000 --- a/src/casscf/bielec_create.irp.f +++ /dev/null @@ -1,118 +0,0 @@ -! -*- F90 -*- - BEGIN_PROVIDER[real*8, bielec_PQxxtmp, (mo_num, mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb)] -&BEGIN_PROVIDER[real*8, bielec_PxxQtmp, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb, mo_num)] -&BEGIN_PROVIDER[integer, num_PQxx_written] -&BEGIN_PROVIDER[integer, num_PxxQ_written] -BEGIN_DOC -! bielec_PQxx : integral (pq|xx) with p,q arbitrary, x core or active -! bielec_PxxQ : integral (px|xq) with p,q arbitrary, x core or active -! indices are unshifted orbital numbers -END_DOC - implicit none - integer :: i,j,ii,jj,p,q,i3,j3,t3,v3 - double precision, allocatable :: integrals_array1(:,:) - double precision, allocatable :: integrals_array2(:,:) - real*8 :: mo_two_e_integral - - allocate(integrals_array1(mo_num,mo_num)) - allocate(integrals_array2(mo_num,mo_num)) - - do i=1,n_core_orb+n_act_orb - do j=1,n_core_orb+n_act_orb - do p=1,mo_num - do q=1,mo_num - bielec_PQxxtmp(p,q,i,j)=0.D0 - bielec_PxxQtmp(p,i,j,q)=0.D0 - end do - end do - end do - end do - - do i=1,n_core_orb - ii=list_core(i) - do j=i,n_core_orb - jj=list_core(j) -! (ij|pq) - call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array1,mo_integrals_map) -! (ip|qj) - call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array2,mo_integrals_map) - do p=1,mo_num - do q=1,mo_num - bielec_PQxxtmp(p,q,i,j)=integrals_array1(p,q) - bielec_PQxxtmp(p,q,j,i)=integrals_array1(p,q) - bielec_PxxQtmp(p,i,j,q)=integrals_array2(p,q) - bielec_PxxQtmp(p,j,i,q)=integrals_array2(q,p) - end do - end do - end do - do j=1,n_act_orb - jj=list_act(j) - j3=j+n_core_orb -! (ij|pq) - call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array1,mo_integrals_map) -! (ip|qj) - call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array2,mo_integrals_map) - do p=1,mo_num - do q=1,mo_num - bielec_PQxxtmp(p,q,i,j3)=integrals_array1(p,q) - bielec_PQxxtmp(p,q,j3,i)=integrals_array1(p,q) - bielec_PxxQtmp(p,i,j3,q)=integrals_array2(p,q) - bielec_PxxQtmp(p,j3,i,q)=integrals_array2(q,p) - end do - end do - end do - end do - do i=1,n_act_orb - ii=list_act(i) - i3=i+n_core_orb - do j=i,n_act_orb - jj=list_act(j) - j3=j+n_core_orb -! (ij|pq) - call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array1,mo_integrals_map) -! (ip|qj) - call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array2,mo_integrals_map) - do p=1,mo_num - do q=1,mo_num - bielec_PQxxtmp(p,q,i3,j3)=integrals_array1(p,q) - bielec_PQxxtmp(p,q,j3,i3)=integrals_array1(p,q) - bielec_PxxQtmp(p,i3,j3,q)=integrals_array2(p,q) - bielec_PxxQtmp(p,j3,i3,q)=integrals_array2(q,p) - end do - end do - end do - end do - write(6,*) ' provided integrals (PQ|xx) ' - write(6,*) ' provided integrals (Px|xQ) ' -!!$ write(6,*) ' 1 1 1 2 = ',bielec_PQxxtmp(2,2,2,3),bielec_PxxQtmp(2,2,2,3) -END_PROVIDER - -BEGIN_PROVIDER[real*8, bielecCItmp, (n_act_orb,n_act_orb,n_act_orb, mo_num)] -BEGIN_DOC -! bielecCI : integrals (tu|vp) with p arbitrary, tuv active -! index p runs over the whole basis, t,u,v only over the active orbitals -END_DOC - implicit none - integer :: i,j,k,p,t,u,v - double precision, allocatable :: integrals_array1(:) - real*8 :: mo_two_e_integral - - allocate(integrals_array1(mo_num)) - - do i=1,n_act_orb - t=list_act(i) - do j=1,n_act_orb - u=list_act(j) - do k=1,n_act_orb - v=list_act(k) -! (tu|vp) - call get_mo_two_e_integrals(t,u,v,mo_num,integrals_array1,mo_integrals_map) - do p=1,mo_num - bielecCItmp(i,k,j,p)=integrals_array1(p) - end do - end do - end do - end do - write(6,*) ' provided integrals (tu|xP) ' -END_PROVIDER - diff --git a/src/casscf/bielec_natorb.irp.f b/src/casscf/bielec_natorb.irp.f new file mode 100644 index 00000000..2f1e43eb --- /dev/null +++ b/src/casscf/bielec_natorb.irp.f @@ -0,0 +1,273 @@ + BEGIN_PROVIDER [real*8, bielec_PQxx_no, (mo_num, mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb)] + BEGIN_DOC + ! integral (pq|xx) in the basis of natural MOs + ! indices are unshifted orbital numbers + END_DOC + implicit none + integer :: i,j,k,l,t,u,p,q,pp + real*8 :: d(n_act_orb) + + bielec_PQxx_no(:,:,:,:) = bielec_PQxx(:,:,:,:) + + do j=1,mo_num + do k=1,n_core_orb+n_act_orb + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielec_PQxx_no(list_act(q),j,k,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PQxx_no(list_act(p),j,k,l)=d(p) + end do + end do + end do + end do + ! 2nd quarter + do j=1,mo_num + do k=1,n_core_orb+n_act_orb + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielec_PQxx_no(j,list_act(q),k,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PQxx_no(j,list_act(p),k,l)=d(p) + end do + end do + end do + end do + ! 3rd quarter + do j=1,mo_num + do k=1,mo_num + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielec_PQxx_no(j,k,n_core_orb+q,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PQxx_no(j,k,n_core_orb+p,l)=d(p) + end do + end do + end do + end do + ! 4th quarter + do j=1,mo_num + do k=1,mo_num + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielec_PQxx_no(j,k,l,n_core_orb+q)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PQxx_no(j,k,l,n_core_orb+p)=d(p) + end do + end do + end do + end do + write(6,*) ' transformed PQxx' + +END_PROVIDER + + + +BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb, mo_num)] + BEGIN_DOC + ! integral (px|xq) in the basis of natural MOs + ! indices are unshifted orbital numbers + END_DOC + implicit none + integer :: i,j,k,l,t,u,p,q,pp + real*8 :: d(n_act_orb) + + bielec_PxxQ_no(:,:,:,:) = bielec_PxxQ(:,:,:,:) + + do j=1,mo_num + do k=1,n_core_orb+n_act_orb + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielec_PxxQ_no(list_act(q),k,l,j)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PxxQ_no(list_act(p),k,l,j)=d(p) + end do + end do + end do + end do + ! 2nd quarter + do j=1,mo_num + do k=1,n_core_orb+n_act_orb + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielec_PxxQ_no(j,k,l,list_act(q))*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PxxQ_no(j,k,l,list_act(p))=d(p) + end do + end do + end do + end do + ! 3rd quarter + do j=1,mo_num + do k=1,mo_num + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielec_PxxQ_no(j,n_core_orb+q,l,k)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PxxQ_no(j,n_core_orb+p,l,k)=d(p) + end do + end do + end do + end do + ! 4th quarter + do j=1,mo_num + do k=1,mo_num + do l=1,n_core_orb+n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielec_PxxQ_no(j,l,n_core_orb+q,k)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielec_PxxQ_no(j,l,n_core_orb+p,k)=d(p) + end do + end do + end do + end do + write(6,*) ' transformed PxxQ ' + +END_PROVIDER + + +BEGIN_PROVIDER [real*8, bielecCI_no, (n_act_orb,n_act_orb,n_act_orb, mo_num)] + BEGIN_DOC + ! integrals (tu|vp) in the basis of natural MOs + ! index p runs over the whole basis, t,u,v only over the active orbitals + END_DOC + implicit none + integer :: i,j,k,l,t,u,p,q,pp + real*8 :: d(n_act_orb) + + bielecCI_no(:,:,:,:) = bielecCI(:,:,:,:) + + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,mo_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielecCI_no(q,j,k,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielecCI_no(p,j,k,l)=d(p) + end do + end do + end do + end do + ! 2nd quarter + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,mo_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielecCI_no(j,q,k,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielecCI_no(j,p,k,l)=d(p) + end do + end do + end do + end do + ! 3rd quarter + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,mo_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielecCI_no(j,k,q,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielecCI_no(j,k,p,l)=d(p) + end do + end do + end do + end do + ! 4th quarter + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=bielecCI_no(j,k,l,list_act(q))*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + bielecCI_no(j,k,l,list_act(p))=d(p) + end do + end do + end do + end do + write(6,*) ' transformed tuvP ' + +END_PROVIDER + diff --git a/src/casscf/densities.irp.f b/src/casscf/densities.irp.f index 77f5593e..6e8065e2 100644 --- a/src/casscf/densities.irp.f +++ b/src/casscf/densities.irp.f @@ -1,177 +1,216 @@ -! -*- F90 -*- -use bitmasks ! you need to include the bitmasks_module.f90 features +use bitmasks - BEGIN_PROVIDER [real*8, D0tu, (n_act_orb,n_act_orb) ] -&BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ] -BEGIN_DOC -! the first-order density matrix in the basis of the starting MOs -! the second-order density matrix in the basis of the starting MOs -! matrices are state averaged -! -! we use the spin-free generators of mono-excitations -! E_pq destroys q and creates p -! D_pq = <0|E_pq|0> = D_qp -! P_pqrs = 1/2 <0|E_pq E_rs - delta_qr E_ps|0> -! -END_DOC - implicit none - integer :: t,u,v,x,mu,nu,istate,ispin,jspin,ihole,ipart,jhole,jpart - integer :: ierr - integer(bit_kind), allocatable :: det_mu(:,:) - integer(bit_kind), allocatable :: det_mu_ex(:,:) - integer(bit_kind), allocatable :: det_mu_ex1(:,:) - integer(bit_kind), allocatable :: det_mu_ex11(:,:) - integer(bit_kind), allocatable :: det_mu_ex12(:,:) - integer(bit_kind), allocatable :: det_mu_ex2(:,:) - integer(bit_kind), allocatable :: det_mu_ex21(:,:) - integer(bit_kind), allocatable :: det_mu_ex22(:,:) - real*8 :: phase1,phase11,phase12,phase2,phase21,phase22 - integer :: nu1,nu2,nu11,nu12,nu21,nu22 - integer :: ierr1,ierr2,ierr11,ierr12,ierr21,ierr22 - real*8 :: cI_mu(N_states),term - allocate(det_mu(N_int,2)) - allocate(det_mu_ex(N_int,2)) - allocate(det_mu_ex1(N_int,2)) - allocate(det_mu_ex11(N_int,2)) - allocate(det_mu_ex12(N_int,2)) - allocate(det_mu_ex2(N_int,2)) - allocate(det_mu_ex21(N_int,2)) - allocate(det_mu_ex22(N_int,2)) - - write(6,*) ' providing density matrices D0 and P0 ' - -! set all to zero - do t=1,n_act_orb - do u=1,n_act_orb - D0tu(u,t)=0.D0 - do v=1,n_act_orb - do x=1,n_act_orb - P0tuvx(x,v,u,t)=0.D0 - end do - end do - end do - end do - -! first loop: we apply E_tu, once for D_tu, once for -P_tvvu - do mu=1,n_det - call det_extract(det_mu,mu,N_int) - do istate=1,n_states - cI_mu(istate)=psi_coef(mu,istate) - end do - do t=1,n_act_orb - ipart=list_act(t) - do u=1,n_act_orb - ihole=list_act(u) -! apply E_tu - call det_copy(det_mu,det_mu_ex1,N_int) - call det_copy(det_mu,det_mu_ex2,N_int) - call do_spinfree_mono_excitation(det_mu,det_mu_ex1 & +BEGIN_PROVIDER [real*8, D0tu, (n_act_orb,n_act_orb) ] + BEGIN_DOC + ! the first-order density matrix in the basis of the starting MOs + ! matrices are state averaged + ! + ! we use the spin-free generators of mono-excitations + ! E_pq destroys q and creates p + ! D_pq = <0|E_pq|0> = D_qp + ! + END_DOC + implicit none + integer :: t,u,v,x,mu,nu,istate,ispin,jspin,ihole,ipart,jhole,jpart + integer :: ierr + integer(bit_kind) :: det_mu(N_int,2) + integer(bit_kind) :: det_mu_ex(N_int,2) + integer(bit_kind) :: det_mu_ex1(N_int,2) + integer(bit_kind) :: det_mu_ex2(N_int,2) + real*8 :: phase1,phase2,term + integer :: nu1,nu2 + integer :: ierr1,ierr2 + real*8 :: cI_mu(N_states) + + write(6,*) ' providing density matrices D0 and P0 ' + + D0tu = 0.d0 + + ! first loop: we apply E_tu, once for D_tu, once for -P_tvvu + do mu=1,n_det + call det_extract(det_mu,mu,N_int) + do istate=1,n_states + cI_mu(istate)=psi_coef(mu,istate) + end do + do t=1,n_act_orb + ipart=list_act(t) + do u=1,n_act_orb + ihole=list_act(u) + ! apply E_tu + call det_copy(det_mu,det_mu_ex1,N_int) + call det_copy(det_mu,det_mu_ex2,N_int) + call do_spinfree_mono_excitation(det_mu,det_mu_ex1 & ,det_mu_ex2,nu1,nu2,ihole,ipart,phase1,phase2,ierr1,ierr2) -! det_mu_ex1 is in the list - if (nu1.ne.-1) then + ! det_mu_ex1 is in the list + if (nu1.ne.-1) then do istate=1,n_states - term=cI_mu(istate)*psi_coef(nu1,istate)*phase1 - D0tu(t,u)+=term -! and we fill P0_tvvu - do v=1,n_act_orb - P0tuvx(t,v,v,u)-=term - end do + term=cI_mu(istate)*psi_coef(nu1,istate)*phase1 + D0tu(t,u)+=term end do - end if -! det_mu_ex2 is in the list - if (nu2.ne.-1) then + end if + ! det_mu_ex2 is in the list + if (nu2.ne.-1) then do istate=1,n_states - term=cI_mu(istate)*psi_coef(nu2,istate)*phase2 - D0tu(t,u)+=term - do v=1,n_act_orb - P0tuvx(t,v,v,u)-=term - end do + term=cI_mu(istate)*psi_coef(nu2,istate)*phase2 + D0tu(t,u)+=term end do - end if - end do - end do + end if end do -! now we do the double excitation E_tu E_vx |0> - do mu=1,n_det - call det_extract(det_mu,mu,N_int) - do istate=1,n_states - cI_mu(istate)=psi_coef(mu,istate) - end do - do v=1,n_act_orb - ipart=list_act(v) - do x=1,n_act_orb - ihole=list_act(x) -! apply E_vx - call det_copy(det_mu,det_mu_ex1,N_int) - call det_copy(det_mu,det_mu_ex2,N_int) - call do_spinfree_mono_excitation(det_mu,det_mu_ex1 & - ,det_mu_ex2,nu1,nu2,ihole,ipart,phase1,phase2,ierr1,ierr2) -! we apply E_tu to the first resultant determinant, thus E_tu E_vx |0> - if (ierr1.eq.1) then - do t=1,n_act_orb - jpart=list_act(t) - do u=1,n_act_orb - jhole=list_act(u) - call det_copy(det_mu_ex1,det_mu_ex11,N_int) - call det_copy(det_mu_ex1,det_mu_ex12,N_int) - call do_spinfree_mono_excitation(det_mu_ex1,det_mu_ex11 & - ,det_mu_ex12,nu11,nu12,jhole,jpart,phase11,phase12,ierr11,ierr12) - if (nu11.ne.-1) then - do istate=1,n_states - P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu11,istate) & - *phase11*phase1 - end do - end if - if (nu12.ne.-1) then - do istate=1,n_states - P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu12,istate) & - *phase12*phase1 - end do - end if - end do - end do - end if - -! we apply E_tu to the second resultant determinant - if (ierr2.eq.1) then - do t=1,n_act_orb - jpart=list_act(t) - do u=1,n_act_orb - jhole=list_act(u) - call det_copy(det_mu_ex2,det_mu_ex21,N_int) - call det_copy(det_mu_ex2,det_mu_ex22,N_int) - call do_spinfree_mono_excitation(det_mu_ex2,det_mu_ex21 & - ,det_mu_ex22,nu21,nu22,jhole,jpart,phase21,phase22,ierr21,ierr22) - if (nu21.ne.-1) then - do istate=1,n_states - P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu21,istate) & - *phase21*phase2 - end do - end if - if (nu22.ne.-1) then - do istate=1,n_states - P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu22,istate) & - *phase22*phase2 - end do - end if - end do - end do - end if - - end do - end do - end do - -! we average by just dividing by the number of states - do x=1,n_act_orb - do v=1,n_act_orb - D0tu(v,x)*=1.0D0/dble(N_states) - do u=1,n_act_orb - do t=1,n_act_orb - P0tuvx(t,u,v,x)*=0.5D0/dble(N_states) - end do - end do - end do - end do - + end do + end do + + ! we average by just dividing by the number of states + do x=1,n_act_orb + do v=1,n_act_orb + D0tu(v,x)*=1.0D0/dble(N_states) + end do + end do + +END_PROVIDER + +BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ] + BEGIN_DOC + ! the second-order density matrix in the basis of the starting MOs + ! matrices are state averaged + ! + ! we use the spin-free generators of mono-excitations + ! E_pq destroys q and creates p + ! D_pq = <0|E_pq|0> = D_qp + ! P_pqrs = 1/2 <0|E_pq E_rs - delta_qr E_ps|0> + ! + END_DOC + implicit none + integer :: t,u,v,x,mu,nu,istate,ispin,jspin,ihole,ipart,jhole,jpart + integer :: ierr + real*8 :: phase1,phase11,phase12,phase2,phase21,phase22 + integer :: nu1,nu2,nu11,nu12,nu21,nu22 + integer :: ierr1,ierr2,ierr11,ierr12,ierr21,ierr22 + real*8 :: cI_mu(N_states),term + integer(bit_kind), dimension(N_int,2) :: det_mu, det_mu_ex + integer(bit_kind), dimension(N_int,2) :: det_mu_ex1, det_mu_ex11, det_mu_ex12 + integer(bit_kind), dimension(N_int,2) :: det_mu_ex2, det_mu_ex21, det_mu_ex22 + + write(6,*) ' providing density matrices D0 and P0 ' + + P0tuvx = 0.d0 + + ! first loop: we apply E_tu, once for D_tu, once for -P_tvvu + do mu=1,n_det + call det_extract(det_mu,mu,N_int) + do istate=1,n_states + cI_mu(istate)=psi_coef(mu,istate) + end do + do t=1,n_act_orb + ipart=list_act(t) + do u=1,n_act_orb + ihole=list_act(u) + ! apply E_tu + call det_copy(det_mu,det_mu_ex1,N_int) + call det_copy(det_mu,det_mu_ex2,N_int) + call do_spinfree_mono_excitation(det_mu,det_mu_ex1 & + ,det_mu_ex2,nu1,nu2,ihole,ipart,phase1,phase2,ierr1,ierr2) + ! det_mu_ex1 is in the list + if (nu1.ne.-1) then + do istate=1,n_states + term=cI_mu(istate)*psi_coef(nu1,istate)*phase1 + ! and we fill P0_tvvu + do v=1,n_act_orb + P0tuvx(t,v,v,u)-=term + end do + end do + end if + ! det_mu_ex2 is in the list + if (nu2.ne.-1) then + do istate=1,n_states + term=cI_mu(istate)*psi_coef(nu2,istate)*phase2 + do v=1,n_act_orb + P0tuvx(t,v,v,u)-=term + end do + end do + end if + end do + end do + end do + ! now we do the double excitation E_tu E_vx |0> + do mu=1,n_det + call det_extract(det_mu,mu,N_int) + do istate=1,n_states + cI_mu(istate)=psi_coef(mu,istate) + end do + do v=1,n_act_orb + ipart=list_act(v) + do x=1,n_act_orb + ihole=list_act(x) + ! apply E_vx + call det_copy(det_mu,det_mu_ex1,N_int) + call det_copy(det_mu,det_mu_ex2,N_int) + call do_spinfree_mono_excitation(det_mu,det_mu_ex1 & + ,det_mu_ex2,nu1,nu2,ihole,ipart,phase1,phase2,ierr1,ierr2) + ! we apply E_tu to the first resultant determinant, thus E_tu E_vx |0> + if (ierr1.eq.1) then + do t=1,n_act_orb + jpart=list_act(t) + do u=1,n_act_orb + jhole=list_act(u) + call det_copy(det_mu_ex1,det_mu_ex11,N_int) + call det_copy(det_mu_ex1,det_mu_ex12,N_int) + call do_spinfree_mono_excitation(det_mu_ex1,det_mu_ex11& + ,det_mu_ex12,nu11,nu12,jhole,jpart,phase11,phase12,ierr11,ierr12) + if (nu11.ne.-1) then + do istate=1,n_states + P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu11,istate)& + *phase11*phase1 + end do + end if + if (nu12.ne.-1) then + do istate=1,n_states + P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu12,istate)& + *phase12*phase1 + end do + end if + end do + end do + end if + + ! we apply E_tu to the second resultant determinant + if (ierr2.eq.1) then + do t=1,n_act_orb + jpart=list_act(t) + do u=1,n_act_orb + jhole=list_act(u) + call det_copy(det_mu_ex2,det_mu_ex21,N_int) + call det_copy(det_mu_ex2,det_mu_ex22,N_int) + call do_spinfree_mono_excitation(det_mu_ex2,det_mu_ex21& + ,det_mu_ex22,nu21,nu22,jhole,jpart,phase21,phase22,ierr21,ierr22) + if (nu21.ne.-1) then + do istate=1,n_states + P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu21,istate)& + *phase21*phase2 + end do + end if + if (nu22.ne.-1) then + do istate=1,n_states + P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu22,istate)& + *phase22*phase2 + end do + end if + end do + end do + end if + + end do + end do + end do + + ! we average by just dividing by the number of states + do x=1,n_act_orb + do v=1,n_act_orb + do u=1,n_act_orb + do t=1,n_act_orb + P0tuvx(t,u,v,x)*=0.5D0/dble(N_states) + end do + end do + end do + end do + END_PROVIDER diff --git a/src/casscf/det_manip.irp.f b/src/casscf/det_manip.irp.f index c8e6c08a..adf90196 100644 --- a/src/casscf/det_manip.irp.f +++ b/src/casscf/det_manip.irp.f @@ -1,131 +1,130 @@ -! -*- F90 -*- -use bitmasks ! you need to include the bitmasks_module.f90 features +use bitmasks - subroutine do_signed_mono_excitation(key1,key2,nu,ihole,ipart, & - ispin,phase,ierr) -BEGIN_DOC -! we create the mono-excitation, and determine, if possible, -! the phase and the number in the list of determinants -END_DOC - implicit none - integer(bit_kind) :: key1(N_int,2),key2(N_int,2) - integer(bit_kind), allocatable :: keytmp(:,:) - integer :: exc(0:2,2,2),ihole,ipart,ierr,nu,ispin - real*8 :: phase - logical :: found - allocate(keytmp(N_int,2)) - - nu=-1 - phase=1.D0 - ierr=0 - call det_copy(key1,key2,N_int) -! write(6,*) ' key2 before excitation ',ihole,' -> ',ipart,' spin = ',ispin -! call print_det(key2,N_int) - call do_single_excitation(key2,ihole,ipart,ispin,ierr) -! write(6,*) ' key2 after ',ihole,' -> ',ipart,' spin = ',ispin -! call print_det(key2,N_int) -! write(6,*) ' excitation ',ihole,' -> ',ipart,' gives ierr = ',ierr - if (ierr.eq.1) then -! excitation is possible -! get the phase - call get_single_excitation(key1,key2,exc,phase,N_int) -! get the number in the list - found=.false. - nu=0 - do while (.not.found) - nu+=1 - if (nu.gt.N_det) then -! the determinant is possible, but not in the list - found=.true. - nu=-1 - else - call det_extract(keytmp,nu,N_int) -integer :: i,ii - found=.true. - do ii=1,2 - do i=1,N_int - if (keytmp(i,ii).ne.key2(i,ii)) then - found=.false. - end if - end do - end do - end if +subroutine do_signed_mono_excitation(key1,key2,nu,ihole,ipart, & + ispin,phase,ierr) + BEGIN_DOC + ! we create the mono-excitation, and determine, if possible, + ! the phase and the number in the list of determinants + END_DOC + implicit none + integer(bit_kind) :: key1(N_int,2),key2(N_int,2) + integer(bit_kind), allocatable :: keytmp(:,:) + integer :: exc(0:2,2,2),ihole,ipart,ierr,nu,ispin + real*8 :: phase + logical :: found + allocate(keytmp(N_int,2)) + + nu=-1 + phase=1.D0 + ierr=0 + call det_copy(key1,key2,N_int) + ! write(6,*) ' key2 before excitation ',ihole,' -> ',ipart,' spin = ',ispin + ! call print_det(key2,N_int) + call do_single_excitation(key2,ihole,ipart,ispin,ierr) + ! write(6,*) ' key2 after ',ihole,' -> ',ipart,' spin = ',ispin + ! call print_det(key2,N_int) + ! write(6,*) ' excitation ',ihole,' -> ',ipart,' gives ierr = ',ierr + if (ierr.eq.1) then + ! excitation is possible + ! get the phase + call get_single_excitation(key1,key2,exc,phase,N_int) + ! get the number in the list + found=.false. + nu=0 + do while (.not.found) + nu+=1 + if (nu.gt.N_det) then + ! the determinant is possible, but not in the list + found=.true. + nu=-1 + else + call det_extract(keytmp,nu,N_int) + integer :: i,ii + found=.true. + do ii=1,2 + do i=1,N_int + if (keytmp(i,ii).ne.key2(i,ii)) then + found=.false. + end if end do -! if (found) then -! if (nu.eq.-1) then -! write(6,*) ' image not found in the list, thus nu = ',nu -! else -! write(6,*) ' found in the list as No ',nu,' phase = ',phase -! end if -! end if - end if -! -! we found the new string, the phase, and possibly the number in the list -! - end subroutine do_signed_mono_excitation + end do + end if + end do + ! if (found) then + ! if (nu.eq.-1) then + ! write(6,*) ' image not found in the list, thus nu = ',nu + ! else + ! write(6,*) ' found in the list as No ',nu,' phase = ',phase + ! end if + ! end if + end if + ! + ! we found the new string, the phase, and possibly the number in the list + ! +end subroutine do_signed_mono_excitation - subroutine det_extract(key,nu,Nint) -BEGIN_DOC -! extract a determinant from the list of determinants -END_DOC - implicit none - integer :: ispin,i,nu,Nint - integer(bit_kind) :: key(Nint,2) - do ispin=1,2 - do i=1,Nint - key(i,ispin)=psi_det(i,ispin,nu) - end do - end do - end subroutine det_extract +subroutine det_extract(key,nu,Nint) + BEGIN_DOC + ! extract a determinant from the list of determinants + END_DOC + implicit none + integer :: ispin,i,nu,Nint + integer(bit_kind) :: key(Nint,2) + do ispin=1,2 + do i=1,Nint + key(i,ispin)=psi_det(i,ispin,nu) + end do + end do +end subroutine det_extract - subroutine det_copy(key1,key2,Nint) - use bitmasks ! you need to include the bitmasks_module.f90 features -BEGIN_DOC -! copy a determinant from key1 to key2 -END_DOC - implicit none - integer :: ispin,i,Nint - integer(bit_kind) :: key1(Nint,2),key2(Nint,2) - do ispin=1,2 - do i=1,Nint - key2(i,ispin)=key1(i,ispin) - end do - end do - end subroutine det_copy - - subroutine do_spinfree_mono_excitation(key_in,key_out1,key_out2 & - ,nu1,nu2,ihole,ipart,phase1,phase2,ierr,jerr) -BEGIN_DOC -! we create the spin-free mono-excitation E_pq=(a^+_p a_q + a^+_P a_Q) -! we may create two determinants as result -! -END_DOC - implicit none - integer(bit_kind) :: key_in(N_int,2),key_out1(N_int,2) - integer(bit_kind) :: key_out2(N_int,2) - integer :: ihole,ipart,ierr,jerr,nu1,nu2 - integer :: ispin - real*8 :: phase1,phase2 - -! write(6,*) ' applying E_',ipart,ihole,' on determinant ' -! call print_det(key_in,N_int) - -! spin alpha - ispin=1 - call do_signed_mono_excitation(key_in,key_out1,nu1,ihole & - ,ipart,ispin,phase1,ierr) -! if (ierr.eq.1) then -! write(6,*) ' 1 result is ',nu1,phase1 -! call print_det(key_out1,N_int) -! end if -! spin beta - ispin=2 - call do_signed_mono_excitation(key_in,key_out2,nu2,ihole & - ,ipart,ispin,phase2,jerr) -! if (jerr.eq.1) then -! write(6,*) ' 2 result is ',nu2,phase2 -! call print_det(key_out2,N_int) -! end if +subroutine det_copy(key1,key2,Nint) + use bitmasks ! you need to include the bitmasks_module.f90 features + BEGIN_DOC + ! copy a determinant from key1 to key2 + END_DOC + implicit none + integer :: ispin,i,Nint + integer(bit_kind) :: key1(Nint,2),key2(Nint,2) + do ispin=1,2 + do i=1,Nint + key2(i,ispin)=key1(i,ispin) + end do + end do +end subroutine det_copy - end subroutine do_spinfree_mono_excitation +subroutine do_spinfree_mono_excitation(key_in,key_out1,key_out2 & + ,nu1,nu2,ihole,ipart,phase1,phase2,ierr,jerr) + BEGIN_DOC + ! we create the spin-free mono-excitation E_pq=(a^+_p a_q + a^+_P a_Q) + ! we may create two determinants as result + ! + END_DOC + implicit none + integer(bit_kind) :: key_in(N_int,2),key_out1(N_int,2) + integer(bit_kind) :: key_out2(N_int,2) + integer :: ihole,ipart,ierr,jerr,nu1,nu2 + integer :: ispin + real*8 :: phase1,phase2 + + ! write(6,*) ' applying E_',ipart,ihole,' on determinant ' + ! call print_det(key_in,N_int) + + ! spin alpha + ispin=1 + call do_signed_mono_excitation(key_in,key_out1,nu1,ihole & + ,ipart,ispin,phase1,ierr) + ! if (ierr.eq.1) then + ! write(6,*) ' 1 result is ',nu1,phase1 + ! call print_det(key_out1,N_int) + ! end if + ! spin beta + ispin=2 + call do_signed_mono_excitation(key_in,key_out2,nu2,ihole & + ,ipart,ispin,phase2,jerr) + ! if (jerr.eq.1) then + ! write(6,*) ' 2 result is ',nu2,phase2 + ! call print_det(key_out2,N_int) + ! end if + +end subroutine do_spinfree_mono_excitation diff --git a/src/casscf/driver_wdens.irp.f b/src/casscf/driver_wdens.irp.f index 263e8441..5a3863a3 100644 --- a/src/casscf/driver_wdens.irp.f +++ b/src/casscf/driver_wdens.irp.f @@ -7,58 +7,13 @@ write(6,*) ' generating natural orbitals ' write(6,*) write(6,*) - call trf_to_natorb write(6,*) ' all data available ! ' write(6,*) ' writing out files ' - open(unit=12,file='D0tu.dat',form='formatted',status='unknown') - do p=1,n_act_orb - do q=1,n_act_orb - if (abs(D0tu(p,q)).gt.1.D-12) then - write(12,'(2i8,E20.12)') p,q,D0tu(p,q) - end if - end do - end do - close(12) - + call trf_to_natorb real*8 :: approx,np,nq,nr,ns logical :: lpq,lrs,lps,lqr - open(unit=12,file='P0tuvx.dat',form='formatted',status='unknown') - do p=1,n_act_orb - np=D0tu(p,p) - do q=1,n_act_orb - lpq=p.eq.q - nq=D0tu(q,q) - do r=1,n_act_orb - lqr=q.eq.r - nr=D0tu(r,r) - do s=1,n_act_orb - lrs=r.eq.s - lps=p.eq.s - approx=0.D0 - if (lpq.and.lrs) then - if (lqr) then -! pppp - approx=0.5D0*np*(np-1.D0) - else -! pprr - approx=0.5D0*np*nr - end if - else - if (lps.and.lqr.and..not.lpq) then -! pqqp - approx=-0.25D0*np*nq - end if - end if - if (abs(P0tuvx(p,q,r,s)).gt.1.D-12) then - write(12,'(4i4,2E20.12)') p,q,r,s,P0tuvx(p,q,r,s),approx - end if - end do - end do - end do - end do - close(12) open(unit=12,form='formatted',status='unknown',file='onetrf.tmp') indx=0 @@ -74,63 +29,6 @@ logical :: lpq,lrs,lps,lqr close(12) - open(unit=12,form='formatted',status='unknown',file='bielec_PQxx.tmp') - indx=0 - do p=1,mo_num - do q=p,mo_num - do r=1,n_core_orb+n_act_orb - do s=r,n_core_orb+n_act_orb - if (abs(bielec_PQxxtmp(p,q,r,s)).gt.1.D-12) then - write(12,'(4i8,E20.12)') p,q,r,s,bielec_PQxxtmp(p,q,r,s) - indx+=1 - end if - end do - end do - end do - end do - write(6,*) ' wrote ',indx,' integrals (PQ|xx)' - close(12) - - open(unit=12,form='formatted',status='unknown',file='bielec_PxxQ.tmp') - indx=0 - do p=1,mo_num - do q=1,n_core_orb+n_act_orb - do r=q,n_core_orb+n_act_orb -integer ::s_start - if (q.eq.r) then - s_start=p - else - s_start=1 - end if - do s=s_start,mo_num - if (abs(bielec_PxxQtmp(p,q,r,s)).gt.1.D-12) then - write(12,'(4i8,E20.12)') p,q,r,s,bielec_PxxQtmp(p,q,r,s) - indx+=1 - end if - end do - end do - end do - end do - write(6,*) ' wrote ',indx,' integrals (Px|xQ)' - close(12) - - open(unit=12,form='formatted',status='unknown',file='bielecCI.tmp') - indx=0 - do p=1,n_act_orb - do q=p,n_act_orb - do r=1,n_act_orb - do s=1,mo_num - if (abs(bielecCItmp(p,q,r,s)).gt.1.D-12) then - write(12,'(4i8,E20.12)') p,q,r,s,bielecCItmp(p,q,r,s) - indx+=1 - end if - end do - end do - end do - end do - write(6,*) ' wrote ',indx,' integrals (tu|xP)' - close(12) - write(6,*) write(6,*) ' creating new orbitals ' do i=1,mo_num diff --git a/src/casscf/gradient.irp.f b/src/casscf/gradient.irp.f index d35d96ed..606bf12b 100644 --- a/src/casscf/gradient.irp.f +++ b/src/casscf/gradient.irp.f @@ -1,251 +1,249 @@ -! -*- F90 -*- - -use bitmasks ! you need to include the bitmasks_module.f90 features +use bitmasks BEGIN_PROVIDER [ integer, nMonoEx ] -BEGIN_DOC -! -END_DOC - implicit none - nMonoEx=n_core_orb*n_act_orb+n_core_orb*n_virt_orb+n_act_orb*n_virt_orb - write(6,*) ' nMonoEx = ',nMonoEx + BEGIN_DOC + ! Number of single excitations + END_DOC + implicit none + nMonoEx=n_core_orb*n_act_orb+n_core_orb*n_virt_orb+n_act_orb*n_virt_orb + write(6,*) ' nMonoEx = ',nMonoEx END_PROVIDER BEGIN_PROVIDER [integer, excit, (2,nMonoEx)] &BEGIN_PROVIDER [character*3, excit_class, (nMonoEx)] -BEGIN_DOC -! a list of the orbitals involved in the excitation -END_DOC - - implicit none - integer :: i,t,a,ii,tt,aa,indx - indx=0 - do ii=1,n_core_orb - i=list_core(ii) - do tt=1,n_act_orb - t=list_act(tt) - indx+=1 - excit(1,indx)=i - excit(2,indx)=t - excit_class(indx)='c-a' - end do - end do - - do ii=1,n_core_orb - i=list_core(ii) - do aa=1,n_virt_orb - a=list_virt(aa) - indx+=1 - excit(1,indx)=i - excit(2,indx)=a - excit_class(indx)='c-v' - end do - end do - - do tt=1,n_act_orb + BEGIN_DOC + ! a list of the orbitals involved in the excitation + END_DOC + + implicit none + integer :: i,t,a,ii,tt,aa,indx + indx=0 + do ii=1,n_core_orb + i=list_core(ii) + do tt=1,n_act_orb t=list_act(tt) - do aa=1,n_virt_orb - a=list_virt(aa) - indx+=1 - excit(1,indx)=t - excit(2,indx)=a - excit_class(indx)='a-v' - end do - end do - - if (bavard) then - write(6,*) ' Filled the table of the Monoexcitations ' - do indx=1,nMonoEx - write(6,*) ' ex ',indx,' : ',excit(1,indx),' -> ' & - ,excit(2,indx),' ',excit_class(indx) - end do - end if - + indx+=1 + excit(1,indx)=i + excit(2,indx)=t + excit_class(indx)='c-a' + end do + end do + + do ii=1,n_core_orb + i=list_core(ii) + do aa=1,n_virt_orb + a=list_virt(aa) + indx+=1 + excit(1,indx)=i + excit(2,indx)=a + excit_class(indx)='c-v' + end do + end do + + do tt=1,n_act_orb + t=list_act(tt) + do aa=1,n_virt_orb + a=list_virt(aa) + indx+=1 + excit(1,indx)=t + excit(2,indx)=a + excit_class(indx)='a-v' + end do + end do + + if (bavard) then + write(6,*) ' Filled the table of the Monoexcitations ' + do indx=1,nMonoEx + write(6,*) ' ex ',indx,' : ',excit(1,indx),' -> ' & + ,excit(2,indx),' ',excit_class(indx) + end do + end if + END_PROVIDER BEGIN_PROVIDER [real*8, gradvec, (nMonoEx)] -BEGIN_DOC -! calculate the orbital gradient by hand, i.e. for -! each determinant I we determine the string E_pq |I> (alpha and beta -! separately) and generate -! sum_I c_I is then the pq component of the orbital -! gradient -! E_pq = a^+_pa_q + a^+_Pa_Q -END_DOC - implicit none - integer :: ii,tt,aa,indx,ihole,ipart,istate - real*8 :: res - - do indx=1,nMonoEx - ihole=excit(1,indx) - ipart=excit(2,indx) - call calc_grad_elem(ihole,ipart,res) - gradvec(indx)=res - end do - -real*8 :: norm_grad - norm_grad=0.d0 - do indx=1,nMonoEx - norm_grad+=gradvec(indx)*gradvec(indx) - end do - norm_grad=sqrt(norm_grad) - write(6,*) - write(6,*) ' Norm of the orbital gradient (via <0|EH|0>) : ', norm_grad - write(6,*) - - + BEGIN_DOC + ! calculate the orbital gradient by hand, i.e. for + ! each determinant I we determine the string E_pq |I> (alpha and beta + ! separately) and generate + ! sum_I c_I is then the pq component of the orbital + ! gradient + ! E_pq = a^+_pa_q + a^+_Pa_Q + END_DOC + implicit none + integer :: ii,tt,aa,indx,ihole,ipart,istate + real*8 :: res + + do indx=1,nMonoEx + ihole=excit(1,indx) + ipart=excit(2,indx) + call calc_grad_elem(ihole,ipart,res) + gradvec(indx)=res + end do + + real*8 :: norm_grad + norm_grad=0.d0 + do indx=1,nMonoEx + norm_grad+=gradvec(indx)*gradvec(indx) + end do + norm_grad=sqrt(norm_grad) + write(6,*) + write(6,*) ' Norm of the orbital gradient (via <0|EH|0>) : ', norm_grad + write(6,*) + + END_PROVIDER - subroutine calc_grad_elem(ihole,ipart,res) -BEGIN_DOC -! eq 18 of Siegbahn et al, Physica Scripta 1980 -! we calculate 2 , q=hole, p=particle -END_DOC - implicit none - integer :: ihole,ipart,mu,iii,ispin,ierr,nu,istate - real*8 :: res - integer(bit_kind), allocatable :: det_mu(:,:),det_mu_ex(:,:) - real*8 :: i_H_psi_array(N_states),phase - allocate(det_mu(N_int,2)) - allocate(det_mu_ex(N_int,2)) - - res=0.D0 - - do mu=1,n_det -! get the string of the determinant - call det_extract(det_mu,mu,N_int) - do ispin=1,2 -! do the monoexcitation on it - call det_copy(det_mu,det_mu_ex,N_int) - call do_signed_mono_excitation(det_mu,det_mu_ex,nu & - ,ihole,ipart,ispin,phase,ierr) - if (ierr.eq.1) then -! write(6,*) -! write(6,*) ' mu = ',mu -! call print_det(det_mu,N_int) -! write(6,*) ' generated nu = ',nu,' for excitation ',ihole,' -> ',ipart,' ierr = ',ierr,' phase = ',phase,' ispin = ',ispin -! call print_det(det_mu_ex,N_int) - call i_H_psi(det_mu_ex,psi_det,psi_coef,N_int & - ,N_det,N_det,N_states,i_H_psi_array) - do istate=1,N_states - res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase - end do -! write(6,*) ' contribution = ',i_H_psi_array(1)*psi_coef(mu,1)*phase,res - end if +subroutine calc_grad_elem(ihole,ipart,res) + BEGIN_DOC + ! eq 18 of Siegbahn et al, Physica Scripta 1980 + ! we calculate 2 , q=hole, p=particle + END_DOC + implicit none + integer :: ihole,ipart,mu,iii,ispin,ierr,nu,istate + real*8 :: res + integer(bit_kind), allocatable :: det_mu(:,:),det_mu_ex(:,:) + real*8 :: i_H_psi_array(N_states),phase + allocate(det_mu(N_int,2)) + allocate(det_mu_ex(N_int,2)) + + res=0.D0 + + do mu=1,n_det + ! get the string of the determinant + call det_extract(det_mu,mu,N_int) + do ispin=1,2 + ! do the monoexcitation on it + call det_copy(det_mu,det_mu_ex,N_int) + call do_signed_mono_excitation(det_mu,det_mu_ex,nu & + ,ihole,ipart,ispin,phase,ierr) + if (ierr.eq.1) then + ! write(6,*) + ! write(6,*) ' mu = ',mu + ! call print_det(det_mu,N_int) + ! write(6,*) ' generated nu = ',nu,' for excitation ',ihole,' -> ',ipart,' ierr = ',ierr,' phase = ',phase,' ispin = ',ispin + ! call print_det(det_mu_ex,N_int) + call i_H_psi(det_mu_ex,psi_det,psi_coef,N_int & + ,N_det,N_det,N_states,i_H_psi_array) + do istate=1,N_states + res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase end do - end do - -! state-averaged gradient - res*=2.D0/dble(N_states) - - end subroutine calc_grad_elem + ! write(6,*) ' contribution = ',i_H_psi_array(1)*psi_coef(mu,1)*phase,res + end if + end do + end do + + ! state-averaged gradient + res*=2.D0/dble(N_states) + +end subroutine calc_grad_elem BEGIN_PROVIDER [real*8, gradvec2, (nMonoEx)] -BEGIN_DOC -! calculate the orbital gradient from density -! matrices and integrals; Siegbahn et al, Phys Scr 1980 -! eqs 14 a,b,c -END_DOC - implicit none - integer :: i,t,a,indx - real*8 :: gradvec_it,gradvec_ia,gradvec_ta - real*8 :: norm_grad - - indx=0 - do i=1,n_core_orb - do t=1,n_act_orb - indx+=1 - gradvec2(indx)=gradvec_it(i,t) - end do - end do - - do i=1,n_core_orb - do a=1,n_virt_orb - indx+=1 - gradvec2(indx)=gradvec_ia(i,a) - end do - end do - - do t=1,n_act_orb - do a=1,n_virt_orb - indx+=1 - gradvec2(indx)=gradvec_ta(t,a) - end do - end do - - norm_grad=0.d0 - do indx=1,nMonoEx - norm_grad+=gradvec2(indx)*gradvec2(indx) - end do - norm_grad=sqrt(norm_grad) - write(6,*) - write(6,*) ' Norm of the orbital gradient (via D, P and integrals): ', norm_grad - write(6,*) - + BEGIN_DOC + ! calculate the orbital gradient from density + ! matrices and integrals; Siegbahn et al, Phys Scr 1980 + ! eqs 14 a,b,c + END_DOC + implicit none + integer :: i,t,a,indx + real*8 :: gradvec_it,gradvec_ia,gradvec_ta + real*8 :: norm_grad + + indx=0 + do i=1,n_core_orb + do t=1,n_act_orb + indx+=1 + gradvec2(indx)=gradvec_it(i,t) + end do + end do + + do i=1,n_core_orb + do a=1,n_virt_orb + indx+=1 + gradvec2(indx)=gradvec_ia(i,a) + end do + end do + + do t=1,n_act_orb + do a=1,n_virt_orb + indx+=1 + gradvec2(indx)=gradvec_ta(t,a) + end do + end do + + norm_grad=0.d0 + do indx=1,nMonoEx + norm_grad+=gradvec2(indx)*gradvec2(indx) + end do + norm_grad=sqrt(norm_grad) + write(6,*) + write(6,*) ' Norm of the orbital gradient (via D, P and integrals): ', norm_grad + write(6,*) + END_PROVIDER - real*8 function gradvec_it(i,t) -BEGIN_DOC -! the orbital gradient core -> active -! we assume natural orbitals -END_DOC - implicit none - integer :: i,t +real*8 function gradvec_it(i,t) + BEGIN_DOC + ! the orbital gradient core -> active + ! we assume natural orbitals + END_DOC + implicit none + integer :: i,t + + integer :: ii,tt,v,vv,x,y + integer :: x3,y3 + + ii=list_core(i) + tt=list_act(t) + gradvec_it=2.D0*(Fipq(tt,ii)+Fapq(tt,ii)) + gradvec_it-=occnum(tt)*Fipq(ii,tt) + do v=1,n_act_orb + vv=list_act(v) + do x=1,n_act_orb + x3=x+n_core_orb + do y=1,n_act_orb + y3=y+n_core_orb + gradvec_it-=2.D0*P0tuvx_no(t,v,x,y)*bielec_PQxx_no(ii,vv,x3,y3) + end do + end do + end do + gradvec_it*=2.D0 +end function gradvec_it - integer :: ii,tt,v,vv,x,y - integer :: x3,y3 +real*8 function gradvec_ia(i,a) + BEGIN_DOC + ! the orbital gradient core -> virtual + END_DOC + implicit none + integer :: i,a,ii,aa + + ii=list_core(i) + aa=list_virt(a) + gradvec_ia=2.D0*(Fipq(aa,ii)+Fapq(aa,ii)) + gradvec_ia*=2.D0 + +end function gradvec_ia - ii=list_core(i) - tt=list_act(t) - gradvec_it=2.D0*(Fipq(tt,ii)+Fapq(tt,ii)) - gradvec_it-=occnum(tt)*Fipq(ii,tt) - do v=1,n_act_orb - vv=list_act(v) - do x=1,n_act_orb - x3=x+n_core_orb - do y=1,n_act_orb - y3=y+n_core_orb - gradvec_it-=2.D0*P0tuvx_no(t,v,x,y)*bielec_PQxx(ii,vv,x3,y3) - end do - end do - end do - gradvec_it*=2.D0 - end function gradvec_it - - real*8 function gradvec_ia(i,a) -BEGIN_DOC -! the orbital gradient core -> virtual -END_DOC - implicit none - integer :: i,a,ii,aa - - ii=list_core(i) - aa=list_virt(a) - gradvec_ia=2.D0*(Fipq(aa,ii)+Fapq(aa,ii)) - gradvec_ia*=2.D0 - - end function gradvec_ia - - real*8 function gradvec_ta(t,a) -BEGIN_DOC -! the orbital gradient active -> virtual -! we assume natural orbitals -END_DOC - implicit none - integer :: t,a,tt,aa,v,vv,x,y - - tt=list_act(t) - aa=list_virt(a) - gradvec_ta=0.D0 - gradvec_ta+=occnum(tt)*Fipq(aa,tt) - do v=1,n_act_orb - do x=1,n_act_orb - do y=1,n_act_orb - gradvec_ta+=2.D0*P0tuvx_no(t,v,x,y)*bielecCI(x,y,v,aa) - end do - end do - end do - gradvec_ta*=2.D0 - - end function gradvec_ta +real*8 function gradvec_ta(t,a) + BEGIN_DOC + ! the orbital gradient active -> virtual + ! we assume natural orbitals + END_DOC + implicit none + integer :: t,a,tt,aa,v,vv,x,y + + tt=list_act(t) + aa=list_virt(a) + gradvec_ta=0.D0 + gradvec_ta+=occnum(tt)*Fipq(aa,tt) + do v=1,n_act_orb + do x=1,n_act_orb + do y=1,n_act_orb + gradvec_ta+=2.D0*P0tuvx_no(t,v,x,y)*bielecCI_no(x,y,v,aa) + end do + end do + end do + gradvec_ta*=2.D0 + +end function gradvec_ta diff --git a/src/casscf/hessian.irp.f b/src/casscf/hessian.irp.f index 4603d11e..65734a25 100644 --- a/src/casscf/hessian.irp.f +++ b/src/casscf/hessian.irp.f @@ -1,639 +1,637 @@ -! -*- F90 -*- - -use bitmasks ! you need to include the bitmasks_module.f90 features +use bitmasks BEGIN_PROVIDER [real*8, hessmat, (nMonoEx,nMonoEx)] -BEGIN_DOC -! calculate the orbital hessian 2 -! + + by hand, -! determinant per determinant, as for the gradient -! -! we assume that we have natural active orbitals -END_DOC - implicit none - integer :: indx,ihole,ipart - integer :: jndx,jhole,jpart - character*3 :: iexc,jexc - real*8 :: res - - write(6,*) ' providing Hessian matrix hessmat ' - write(6,*) ' nMonoEx = ',nMonoEx - - do indx=1,nMonoEx - do jndx=1,nMonoEx - hessmat(indx,jndx)=0.D0 - end do - end do - - do indx=1,nMonoEx - ihole=excit(1,indx) - ipart=excit(2,indx) - iexc=excit_class(indx) - do jndx=indx,nMonoEx - jhole=excit(1,jndx) - jpart=excit(2,jndx) - jexc=excit_class(jndx) - call calc_hess_elem(ihole,ipart,jhole,jpart,res) -! write(6,*) ' Hessian ',ihole,'->',ipart & -! ,' (',iexc,')',jhole,'->',jpart,' (',jexc,')',res - hessmat(indx,jndx)=res - hessmat(jndx,indx)=res - end do - end do - + BEGIN_DOC + ! calculate the orbital hessian 2 + ! + + by hand, + ! determinant per determinant, as for the gradient + ! + ! we assume that we have natural active orbitals + END_DOC + implicit none + integer :: indx,ihole,ipart + integer :: jndx,jhole,jpart + character*3 :: iexc,jexc + real*8 :: res + + write(6,*) ' providing Hessian matrix hessmat ' + write(6,*) ' nMonoEx = ',nMonoEx + + do indx=1,nMonoEx + do jndx=1,nMonoEx + hessmat(indx,jndx)=0.D0 + end do + end do + + do indx=1,nMonoEx + ihole=excit(1,indx) + ipart=excit(2,indx) + iexc=excit_class(indx) + do jndx=indx,nMonoEx + jhole=excit(1,jndx) + jpart=excit(2,jndx) + jexc=excit_class(jndx) + call calc_hess_elem(ihole,ipart,jhole,jpart,res) + ! write(6,*) ' Hessian ',ihole,'->',ipart & + ! ,' (',iexc,')',jhole,'->',jpart,' (',jexc,')',res + hessmat(indx,jndx)=res + hessmat(jndx,indx)=res + end do + end do + END_PROVIDER - subroutine calc_hess_elem(ihole,ipart,jhole,jpart,res) -BEGIN_DOC -! eq 19 of Siegbahn et al, Physica Scripta 1980 -! we calculate 2 -! + + -! average over all states is performed. -! no transition between states. -END_DOC - implicit none - integer :: ihole,ipart,ispin,mu,istate - integer :: jhole,jpart,jspin - integer :: mu_pq, mu_pqrs, mu_rs, mu_rspq, nu_rs,nu - real*8 :: res - integer(bit_kind), allocatable :: det_mu(:,:) - integer(bit_kind), allocatable :: det_nu(:,:) - integer(bit_kind), allocatable :: det_mu_pq(:,:) - integer(bit_kind), allocatable :: det_mu_rs(:,:) - integer(bit_kind), allocatable :: det_nu_rs(:,:) - integer(bit_kind), allocatable :: det_mu_pqrs(:,:) - integer(bit_kind), allocatable :: det_mu_rspq(:,:) - real*8 :: i_H_psi_array(N_states),phase,phase2,phase3 - real*8 :: i_H_j_element - allocate(det_mu(N_int,2)) - allocate(det_nu(N_int,2)) - allocate(det_mu_pq(N_int,2)) - allocate(det_mu_rs(N_int,2)) - allocate(det_nu_rs(N_int,2)) - allocate(det_mu_pqrs(N_int,2)) - allocate(det_mu_rspq(N_int,2)) - integer :: mu_pq_possible - integer :: mu_rs_possible - integer :: nu_rs_possible - integer :: mu_pqrs_possible - integer :: mu_rspq_possible - - res=0.D0 - -! the terms <0|E E H |0> - do mu=1,n_det -! get the string of the determinant - call det_extract(det_mu,mu,N_int) - do ispin=1,2 -! do the monoexcitation pq on it - call det_copy(det_mu,det_mu_pq,N_int) - call do_signed_mono_excitation(det_mu,det_mu_pq,mu_pq & - ,ihole,ipart,ispin,phase,mu_pq_possible) - if (mu_pq_possible.eq.1) then -! possible, but not necessarily in the list -! do the second excitation - do jspin=1,2 - call det_copy(det_mu_pq,det_mu_pqrs,N_int) - call do_signed_mono_excitation(det_mu_pq,det_mu_pqrs,mu_pqrs & +subroutine calc_hess_elem(ihole,ipart,jhole,jpart,res) + BEGIN_DOC + ! eq 19 of Siegbahn et al, Physica Scripta 1980 + ! we calculate 2 + ! + + + ! average over all states is performed. + ! no transition between states. + END_DOC + implicit none + integer :: ihole,ipart,ispin,mu,istate + integer :: jhole,jpart,jspin + integer :: mu_pq, mu_pqrs, mu_rs, mu_rspq, nu_rs,nu + real*8 :: res + integer(bit_kind), allocatable :: det_mu(:,:) + integer(bit_kind), allocatable :: det_nu(:,:) + integer(bit_kind), allocatable :: det_mu_pq(:,:) + integer(bit_kind), allocatable :: det_mu_rs(:,:) + integer(bit_kind), allocatable :: det_nu_rs(:,:) + integer(bit_kind), allocatable :: det_mu_pqrs(:,:) + integer(bit_kind), allocatable :: det_mu_rspq(:,:) + real*8 :: i_H_psi_array(N_states),phase,phase2,phase3 + real*8 :: i_H_j_element + allocate(det_mu(N_int,2)) + allocate(det_nu(N_int,2)) + allocate(det_mu_pq(N_int,2)) + allocate(det_mu_rs(N_int,2)) + allocate(det_nu_rs(N_int,2)) + allocate(det_mu_pqrs(N_int,2)) + allocate(det_mu_rspq(N_int,2)) + integer :: mu_pq_possible + integer :: mu_rs_possible + integer :: nu_rs_possible + integer :: mu_pqrs_possible + integer :: mu_rspq_possible + + res=0.D0 + + ! the terms <0|E E H |0> + do mu=1,n_det + ! get the string of the determinant + call det_extract(det_mu,mu,N_int) + do ispin=1,2 + ! do the monoexcitation pq on it + call det_copy(det_mu,det_mu_pq,N_int) + call do_signed_mono_excitation(det_mu,det_mu_pq,mu_pq & + ,ihole,ipart,ispin,phase,mu_pq_possible) + if (mu_pq_possible.eq.1) then + ! possible, but not necessarily in the list + ! do the second excitation + do jspin=1,2 + call det_copy(det_mu_pq,det_mu_pqrs,N_int) + call do_signed_mono_excitation(det_mu_pq,det_mu_pqrs,mu_pqrs& ,jhole,jpart,jspin,phase2,mu_pqrs_possible) -! excitation possible - if (mu_pqrs_possible.eq.1) then - call i_H_psi(det_mu_pqrs,psi_det,psi_coef,N_int & - ,N_det,N_det,N_states,i_H_psi_array) + ! excitation possible + if (mu_pqrs_possible.eq.1) then + call i_H_psi(det_mu_pqrs,psi_det,psi_coef,N_int & + ,N_det,N_det,N_states,i_H_psi_array) do istate=1,N_states - res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase*phase2 + res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase*phase2 end do - end if -! try the de-excitation with opposite sign - call det_copy(det_mu_pq,det_mu_pqrs,N_int) - call do_signed_mono_excitation(det_mu_pq,det_mu_pqrs,mu_pqrs & + end if + ! try the de-excitation with opposite sign + call det_copy(det_mu_pq,det_mu_pqrs,N_int) + call do_signed_mono_excitation(det_mu_pq,det_mu_pqrs,mu_pqrs& ,jpart,jhole,jspin,phase2,mu_pqrs_possible) - phase2=-phase2 -! excitation possible - if (mu_pqrs_possible.eq.1) then - call i_H_psi(det_mu_pqrs,psi_det,psi_coef,N_int & - ,N_det,N_det,N_states,i_H_psi_array) + phase2=-phase2 + ! excitation possible + if (mu_pqrs_possible.eq.1) then + call i_H_psi(det_mu_pqrs,psi_det,psi_coef,N_int & + ,N_det,N_det,N_states,i_H_psi_array) do istate=1,N_states - res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase*phase2 + res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase*phase2 end do - end if - end do - end if -! exchange the notion of pq and rs -! do the monoexcitation rs on the initial determinant - call det_copy(det_mu,det_mu_rs,N_int) - call do_signed_mono_excitation(det_mu,det_mu_rs,mu_rs & - ,jhole,jpart,ispin,phase2,mu_rs_possible) - if (mu_rs_possible.eq.1) then -! do the second excitation - do jspin=1,2 - call det_copy(det_mu_rs,det_mu_rspq,N_int) - call do_signed_mono_excitation(det_mu_rs,det_mu_rspq,mu_rspq & - ,ihole,ipart,jspin,phase3,mu_rspq_possible) -! excitation possible (of course, the result is outside the CAS) - if (mu_rspq_possible.eq.1) then - call i_H_psi(det_mu_rspq,psi_det,psi_coef,N_int & - ,N_det,N_det,N_states,i_H_psi_array) - do istate=1,N_states - res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase2*phase3 - end do - end if -! we may try the de-excitation, with opposite sign - call det_copy(det_mu_rs,det_mu_rspq,N_int) - call do_signed_mono_excitation(det_mu_rs,det_mu_rspq,mu_rspq & - ,ipart,ihole,jspin,phase3,mu_rspq_possible) - phase3=-phase3 -! excitation possible (of course, the result is outside the CAS) - if (mu_rspq_possible.eq.1) then - call i_H_psi(det_mu_rspq,psi_det,psi_coef,N_int & - ,N_det,N_det,N_states,i_H_psi_array) - do istate=1,N_states - res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase2*phase3 - end do - end if - end do - end if -! -! the operator E H E, we have to do a double loop over the determinants -! we still have the determinant mu_pq and the phase in memory - if (mu_pq_possible.eq.1) then - do nu=1,N_det - call det_extract(det_nu,nu,N_int) - do jspin=1,2 - call det_copy(det_nu,det_nu_rs,N_int) - call do_signed_mono_excitation(det_nu,det_nu_rs,nu_rs & - ,jhole,jpart,jspin,phase2,nu_rs_possible) -! excitation possible ? - if (nu_rs_possible.eq.1) then - call i_H_j(det_mu_pq,det_nu_rs,N_int,i_H_j_element) - do istate=1,N_states - res+=2.D0*i_H_j_element*psi_coef(mu,istate) & - *psi_coef(nu,istate)*phase*phase2 - end do - end if - end do - end do - end if + end if end do - end do - -! state-averaged Hessian - res*=1.D0/dble(N_states) - - end subroutine calc_hess_elem + end if + ! exchange the notion of pq and rs + ! do the monoexcitation rs on the initial determinant + call det_copy(det_mu,det_mu_rs,N_int) + call do_signed_mono_excitation(det_mu,det_mu_rs,mu_rs & + ,jhole,jpart,ispin,phase2,mu_rs_possible) + if (mu_rs_possible.eq.1) then + ! do the second excitation + do jspin=1,2 + call det_copy(det_mu_rs,det_mu_rspq,N_int) + call do_signed_mono_excitation(det_mu_rs,det_mu_rspq,mu_rspq& + ,ihole,ipart,jspin,phase3,mu_rspq_possible) + ! excitation possible (of course, the result is outside the CAS) + if (mu_rspq_possible.eq.1) then + call i_H_psi(det_mu_rspq,psi_det,psi_coef,N_int & + ,N_det,N_det,N_states,i_H_psi_array) + do istate=1,N_states + res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase2*phase3 + end do + end if + ! we may try the de-excitation, with opposite sign + call det_copy(det_mu_rs,det_mu_rspq,N_int) + call do_signed_mono_excitation(det_mu_rs,det_mu_rspq,mu_rspq& + ,ipart,ihole,jspin,phase3,mu_rspq_possible) + phase3=-phase3 + ! excitation possible (of course, the result is outside the CAS) + if (mu_rspq_possible.eq.1) then + call i_H_psi(det_mu_rspq,psi_det,psi_coef,N_int & + ,N_det,N_det,N_states,i_H_psi_array) + do istate=1,N_states + res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase2*phase3 + end do + end if + end do + end if + ! + ! the operator E H E, we have to do a double loop over the determinants + ! we still have the determinant mu_pq and the phase in memory + if (mu_pq_possible.eq.1) then + do nu=1,N_det + call det_extract(det_nu,nu,N_int) + do jspin=1,2 + call det_copy(det_nu,det_nu_rs,N_int) + call do_signed_mono_excitation(det_nu,det_nu_rs,nu_rs & + ,jhole,jpart,jspin,phase2,nu_rs_possible) + ! excitation possible ? + if (nu_rs_possible.eq.1) then + call i_H_j(det_mu_pq,det_nu_rs,N_int,i_H_j_element) + do istate=1,N_states + res+=2.D0*i_H_j_element*psi_coef(mu,istate) & + *psi_coef(nu,istate)*phase*phase2 + end do + end if + end do + end do + end if + end do + end do + + ! state-averaged Hessian + res*=1.D0/dble(N_states) + +end subroutine calc_hess_elem BEGIN_PROVIDER [real*8, hessmat2, (nMonoEx,nMonoEx)] -BEGIN_DOC -! explicit hessian matrix from density matrices and integrals -! of course, this will be used for a direct Davidson procedure later -! we will not store the matrix in real life -! formulas are broken down as functions for the 6 classes of matrix elements -! -END_DOC - implicit none - integer :: i,j,t,u,a,b,indx,jndx,bstart,ustart - - real*8 :: hessmat_itju - real*8 :: hessmat_itja - real*8 :: hessmat_itua - real*8 :: hessmat_iajb - real*8 :: hessmat_iatb - real*8 :: hessmat_taub - - write(6,*) ' providing Hessian matrix hessmat2 ' - write(6,*) ' nMonoEx = ',nMonoEx - - indx=1 - do i=1,n_core_orb - do t=1,n_act_orb - jndx=indx - do j=i,n_core_orb - if (i.eq.j) then - ustart=t - else - ustart=1 - end if - do u=ustart,n_act_orb - hessmat2(indx,jndx)=hessmat_itju(i,t,j,u) - hessmat2(jndx,indx)=hessmat2(indx,jndx) -! write(6,*) ' result I :',i,t,j,u,indx,jndx,hessmat(indx,jndx),hessmat2(indx,jndx) - jndx+=1 - end do - end do - do j=1,n_core_orb - do a=1,n_virt_orb - hessmat2(indx,jndx)=hessmat_itja(i,t,j,a) - hessmat2(jndx,indx)=hessmat2(indx,jndx) - jndx+=1 - end do - end do - do u=1,n_act_orb - do a=1,n_virt_orb - hessmat2(indx,jndx)=hessmat_itua(i,t,u,a) - hessmat2(jndx,indx)=hessmat2(indx,jndx) - jndx+=1 - end do - end do - indx+=1 + BEGIN_DOC + ! explicit hessian matrix from density matrices and integrals + ! of course, this will be used for a direct Davidson procedure later + ! we will not store the matrix in real life + ! formulas are broken down as functions for the 6 classes of matrix elements + ! + END_DOC + implicit none + integer :: i,j,t,u,a,b,indx,jndx,bstart,ustart + + real*8 :: hessmat_itju + real*8 :: hessmat_itja + real*8 :: hessmat_itua + real*8 :: hessmat_iajb + real*8 :: hessmat_iatb + real*8 :: hessmat_taub + + write(6,*) ' providing Hessian matrix hessmat2 ' + write(6,*) ' nMonoEx = ',nMonoEx + + indx=1 + do i=1,n_core_orb + do t=1,n_act_orb + jndx=indx + do j=i,n_core_orb + if (i.eq.j) then + ustart=t + else + ustart=1 + end if + do u=ustart,n_act_orb + hessmat2(indx,jndx)=hessmat_itju(i,t,j,u) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + ! write(6,*) ' result I :',i,t,j,u,indx,jndx,hessmat(indx,jndx),hessmat2(indx,jndx) + jndx+=1 end do - end do - - do i=1,n_core_orb + end do + do j=1,n_core_orb do a=1,n_virt_orb - jndx=indx - do j=i,n_core_orb - if (i.eq.j) then - bstart=a - else - bstart=1 - end if - do b=bstart,n_virt_orb - hessmat2(indx,jndx)=hessmat_iajb(i,a,j,b) - hessmat2(jndx,indx)=hessmat2(indx,jndx) - jndx+=1 - end do - end do - do t=1,n_act_orb - do b=1,n_virt_orb - hessmat2(indx,jndx)=hessmat_iatb(i,a,t,b) - hessmat2(jndx,indx)=hessmat2(indx,jndx) - jndx+=1 - end do - end do - indx+=1 + hessmat2(indx,jndx)=hessmat_itja(i,t,j,a) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + jndx+=1 end do - end do - - do t=1,n_act_orb + end do + do u=1,n_act_orb do a=1,n_virt_orb - jndx=indx - do u=t,n_act_orb - if (t.eq.u) then - bstart=a - else - bstart=1 - end if - do b=bstart,n_virt_orb - hessmat2(indx,jndx)=hessmat_taub(t,a,u,b) - hessmat2(jndx,indx)=hessmat2(indx,jndx) - jndx+=1 - end do - end do - indx+=1 + hessmat2(indx,jndx)=hessmat_itua(i,t,u,a) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + jndx+=1 end do - end do - + end do + indx+=1 + end do + end do + + do i=1,n_core_orb + do a=1,n_virt_orb + jndx=indx + do j=i,n_core_orb + if (i.eq.j) then + bstart=a + else + bstart=1 + end if + do b=bstart,n_virt_orb + hessmat2(indx,jndx)=hessmat_iajb(i,a,j,b) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + jndx+=1 + end do + end do + do t=1,n_act_orb + do b=1,n_virt_orb + hessmat2(indx,jndx)=hessmat_iatb(i,a,t,b) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + jndx+=1 + end do + end do + indx+=1 + end do + end do + + do t=1,n_act_orb + do a=1,n_virt_orb + jndx=indx + do u=t,n_act_orb + if (t.eq.u) then + bstart=a + else + bstart=1 + end if + do b=bstart,n_virt_orb + hessmat2(indx,jndx)=hessmat_taub(t,a,u,b) + hessmat2(jndx,indx)=hessmat2(indx,jndx) + jndx+=1 + end do + end do + indx+=1 + end do + end do + END_PROVIDER - real*8 function hessmat_itju(i,t,j,u) -BEGIN_DOC -! the orbital hessian for core->act,core->act -! i, t, j, u are list indices, the corresponding orbitals are ii,tt,jj,uu -! -! we assume natural orbitals -END_DOC - implicit none - integer :: i,t,j,u,ii,tt,uu,v,vv,x,xx,y,jj - real*8 :: term,t2 - -! write(6,*) ' hessmat_itju ',i,t,j,u - ii=list_core(i) - tt=list_act(t) - if (i.eq.j) then - if (t.eq.u) then -! diagonal element - term=occnum(tt)*Fipq(ii,ii)+2.D0*(Fipq(tt,tt)+Fapq(tt,tt)) & - -2.D0*(Fipq(ii,ii)+Fapq(ii,ii)) - term+=2.D0*(3.D0*bielec_pxxq(tt,i,i,tt)-bielec_pqxx(tt,tt,i,i)) - term-=2.D0*occnum(tt)*(3.D0*bielec_pxxq(tt,i,i,tt) & - -bielec_pqxx(tt,tt,i,i)) - term-=occnum(tt)*Fipq(tt,tt) - do v=1,n_act_orb - vv=list_act(v) - do x=1,n_act_orb - xx=list_act(x) - term+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx(vv,xx,i,i) & - +(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* & - bielec_pxxq(vv,i,i,xx)) - do y=1,n_act_orb - term-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI(t,v,y,xx) - end do - end do - end do - else -! it/iu, t != u - uu=list_act(u) - term=2.D0*(Fipq(tt,uu)+Fapq(tt,uu)) - term+=2.D0*(4.D0*bielec_PxxQ(tt,i,j,uu)-bielec_PxxQ(uu,i,j,tt) & - -bielec_PQxx(tt,uu,i,j)) - term-=occnum(tt)*Fipq(uu,tt) - term-=(occnum(tt)+occnum(uu)) & - *(3.D0*bielec_PxxQ(tt,i,i,uu)-bielec_PQxx(uu,tt,i,i)) - do v=1,n_act_orb - vv=list_act(v) -! term-=D0tu(u,v)*Fipq(tt,vv) ! published, but inverting t and u seems more correct - do x=1,n_act_orb - xx=list_act(x) - term+=2.D0*(P0tuvx_no(u,t,v,x)*bielec_pqxx(vv,xx,i,i) & - +(P0tuvx_no(u,x,v,t)+P0tuvx_no(u,x,t,v)) & - *bielec_pxxq(vv,i,i,xx)) - do y=1,n_act_orb - term-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI(u,v,y,xx) - end do - end do - end do -!!! write(6,*) ' direct diff ',i,t,j,u,term,term2 -!!! term=term2 - end if - else -! it/ju - jj=list_core(j) - uu=list_act(u) - if (t.eq.u) then - term=occnum(tt)*Fipq(ii,jj) - term-=2.D0*(Fipq(ii,jj)+Fapq(ii,jj)) - else - term=0.D0 - end if - term+=2.D0*(4.D0*bielec_PxxQ(tt,i,j,uu)-bielec_PxxQ(uu,i,j,tt) & - -bielec_PQxx(tt,uu,i,j)) - term-=(occnum(tt)+occnum(uu))* & - (4.D0*bielec_PxxQ(tt,i,j,uu)-bielec_PxxQ(uu,i,j,tt) & - -bielec_PQxx(uu,tt,i,j)) - do v=1,n_act_orb - vv=list_act(v) - do x=1,n_act_orb +real*8 function hessmat_itju(i,t,j,u) + BEGIN_DOC + ! the orbital hessian for core->act,core->act + ! i, t, j, u are list indices, the corresponding orbitals are ii,tt,jj,uu + ! + ! we assume natural orbitals + END_DOC + implicit none + integer :: i,t,j,u,ii,tt,uu,v,vv,x,xx,y,jj + real*8 :: term,t2 + + ! write(6,*) ' hessmat_itju ',i,t,j,u + ii=list_core(i) + tt=list_act(t) + if (i.eq.j) then + if (t.eq.u) then + ! diagonal element + term=occnum(tt)*Fipq(ii,ii)+2.D0*(Fipq(tt,tt)+Fapq(tt,tt)) & + -2.D0*(Fipq(ii,ii)+Fapq(ii,ii)) + term+=2.D0*(3.D0*bielec_pxxq_no(tt,i,i,tt)-bielec_pqxx_no(tt,tt,i,i)) + term-=2.D0*occnum(tt)*(3.D0*bielec_pxxq_no(tt,i,i,tt) & + -bielec_pqxx_no(tt,tt,i,i)) + term-=occnum(tt)*Fipq(tt,tt) + do v=1,n_act_orb + vv=list_act(v) + do x=1,n_act_orb xx=list_act(x) - term+=2.D0*(P0tuvx_no(u,t,v,x)*bielec_pqxx(vv,xx,i,j) & - +(P0tuvx_no(u,x,v,t)+P0tuvx_no(u,x,t,v)) & - *bielec_pxxq(vv,i,j,xx)) - end do - end do - end if - - term*=2.D0 - hessmat_itju=term - - end function hessmat_itju - - real*8 function hessmat_itja(i,t,j,a) -BEGIN_DOC -! the orbital hessian for core->act,core->virt -END_DOC - implicit none - integer :: i,t,j,a,ii,tt,jj,aa,v,vv,x,y - real*8 :: term - -! write(6,*) ' hessmat_itja ',i,t,j,a -! it/ja - ii=list_core(i) - tt=list_act(t) - jj=list_core(j) - aa=list_virt(a) - term=2.D0*(4.D0*bielec_pxxq(aa,j,i,tt) & - -bielec_pqxx(aa,tt,i,j) -bielec_pxxq(aa,i,j,tt)) - term-=occnum(tt)*(4.D0*bielec_pxxq(aa,j,i,tt) & - -bielec_pqxx(aa,tt,i,j) -bielec_pxxq(aa,i,j,tt)) - if (i.eq.j) then - term+=2.D0*(Fipq(aa,tt)+Fapq(aa,tt)) - term-=0.5D0*occnum(tt)*Fipq(aa,tt) - do v=1,n_act_orb - do x=1,n_act_orb + term+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx_no(vv,xx,i,i) & + +(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* & + bielec_pxxq_no(vv,i,i,xx)) do y=1,n_act_orb - term-=P0tuvx_no(t,v,x,y)*bielecCI(x,y,v,aa) + term-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI_no(t,v,y,xx) end do - end do end do - end if - term*=2.D0 - hessmat_itja=term + end do + else + ! it/iu, t != u + uu=list_act(u) + term=2.D0*(Fipq(tt,uu)+Fapq(tt,uu)) + term+=2.D0*(4.D0*bielec_PxxQ_no(tt,i,j,uu)-bielec_PxxQ_no(uu,i,j,tt) & + -bielec_PQxx_no(tt,uu,i,j)) + term-=occnum(tt)*Fipq(uu,tt) + term-=(occnum(tt)+occnum(uu)) & + *(3.D0*bielec_PxxQ_no(tt,i,i,uu)-bielec_PQxx_no(uu,tt,i,i)) + do v=1,n_act_orb + vv=list_act(v) + ! term-=D0tu(u,v)*Fipq(tt,vv) ! published, but inverting t and u seems more correct + do x=1,n_act_orb + xx=list_act(x) + term+=2.D0*(P0tuvx_no(u,t,v,x)*bielec_pqxx_no(vv,xx,i,i) & + +(P0tuvx_no(u,x,v,t)+P0tuvx_no(u,x,t,v)) & + *bielec_pxxq_no(vv,i,i,xx)) + do y=1,n_act_orb + term-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI_no(u,v,y,xx) + end do + end do + end do + !!! write(6,*) ' direct diff ',i,t,j,u,term,term2 + !!! term=term2 + end if + else + ! it/ju + jj=list_core(j) + uu=list_act(u) + if (t.eq.u) then + term=occnum(tt)*Fipq(ii,jj) + term-=2.D0*(Fipq(ii,jj)+Fapq(ii,jj)) + else + term=0.D0 + end if + term+=2.D0*(4.D0*bielec_PxxQ_no(tt,i,j,uu)-bielec_PxxQ_no(uu,i,j,tt) & + -bielec_PQxx_no(tt,uu,i,j)) + term-=(occnum(tt)+occnum(uu))* & + (4.D0*bielec_PxxQ_no(tt,i,j,uu)-bielec_PxxQ_no(uu,i,j,tt) & + -bielec_PQxx_no(uu,tt,i,j)) + do v=1,n_act_orb + vv=list_act(v) + do x=1,n_act_orb + xx=list_act(x) + term+=2.D0*(P0tuvx_no(u,t,v,x)*bielec_pqxx_no(vv,xx,i,j) & + +(P0tuvx_no(u,x,v,t)+P0tuvx_no(u,x,t,v)) & + *bielec_pxxq_no(vv,i,j,xx)) + end do + end do + end if + + term*=2.D0 + hessmat_itju=term + +end function hessmat_itju - end function hessmat_itja +real*8 function hessmat_itja(i,t,j,a) + BEGIN_DOC + ! the orbital hessian for core->act,core->virt + END_DOC + implicit none + integer :: i,t,j,a,ii,tt,jj,aa,v,vv,x,y + real*8 :: term + + ! write(6,*) ' hessmat_itja ',i,t,j,a + ! it/ja + ii=list_core(i) + tt=list_act(t) + jj=list_core(j) + aa=list_virt(a) + term=2.D0*(4.D0*bielec_pxxq_no(aa,j,i,tt) & + -bielec_pqxx_no(aa,tt,i,j) -bielec_pxxq_no(aa,i,j,tt)) + term-=occnum(tt)*(4.D0*bielec_pxxq_no(aa,j,i,tt) & + -bielec_pqxx_no(aa,tt,i,j) -bielec_pxxq_no(aa,i,j,tt)) + if (i.eq.j) then + term+=2.D0*(Fipq(aa,tt)+Fapq(aa,tt)) + term-=0.5D0*occnum(tt)*Fipq(aa,tt) + do v=1,n_act_orb + do x=1,n_act_orb + do y=1,n_act_orb + term-=P0tuvx_no(t,v,x,y)*bielecCI_no(x,y,v,aa) + end do + end do + end do + end if + term*=2.D0 + hessmat_itja=term + +end function hessmat_itja - real*8 function hessmat_itua(i,t,u,a) -BEGIN_DOC -! the orbital hessian for core->act,act->virt -END_DOC - implicit none - integer :: i,t,u,a,ii,tt,uu,aa,v,vv,x,xx,u3,t3,v3 - real*8 :: term +real*8 function hessmat_itua(i,t,u,a) + BEGIN_DOC + ! the orbital hessian for core->act,act->virt + END_DOC + implicit none + integer :: i,t,u,a,ii,tt,uu,aa,v,vv,x,xx,u3,t3,v3 + real*8 :: term + + ! write(6,*) ' hessmat_itua ',i,t,u,a + ii=list_core(i) + tt=list_act(t) + t3=t+n_core_orb + uu=list_act(u) + u3=u+n_core_orb + aa=list_virt(a) + if (t.eq.u) then + term=-occnum(tt)*Fipq(aa,ii) + else + term=0.D0 + end if + term-=occnum(uu)*(bielec_pqxx_no(aa,ii,t3,u3)-4.D0*bielec_pqxx_no(aa,uu,t3,i)& + +bielec_pxxq_no(aa,t3,u3,ii)) + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_orb + do x=1,n_act_orb + integer :: x3 + xx=list_act(x) + x3=x+n_core_orb + term-=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx_no(aa,ii,v3,x3) & + +(P0tuvx_no(t,v,u,x)+P0tuvx_no(t,v,x,u)) & + *bielec_pqxx_no(aa,xx,v3,i)) + end do + end do + if (t.eq.u) then + term+=Fipq(aa,ii)+Fapq(aa,ii) + end if + term*=2.D0 + hessmat_itua=term + +end function hessmat_itua -! write(6,*) ' hessmat_itua ',i,t,u,a - ii=list_core(i) - tt=list_act(t) - t3=t+n_core_orb - uu=list_act(u) - u3=u+n_core_orb - aa=list_virt(a) - if (t.eq.u) then - term=-occnum(tt)*Fipq(aa,ii) - else - term=0.D0 - end if - term-=occnum(uu)*(bielec_pqxx(aa,ii,t3,u3)-4.D0*bielec_pqxx(aa,uu,t3,i) & - +bielec_pxxq(aa,t3,u3,ii)) - do v=1,n_act_orb +real*8 function hessmat_iajb(i,a,j,b) + BEGIN_DOC + ! the orbital hessian for core->virt,core->virt + END_DOC + implicit none + integer :: i,a,j,b,ii,aa,jj,bb + real*8 :: term + ! write(6,*) ' hessmat_iajb ',i,a,j,b + + ii=list_core(i) + aa=list_virt(a) + if (i.eq.j) then + if (a.eq.b) then + ! ia/ia + term=2.D0*(Fipq(aa,aa)+Fapq(aa,aa)-Fipq(ii,ii)-Fapq(ii,ii)) + term+=2.D0*(3.D0*bielec_pxxq_no(aa,i,i,aa)-bielec_pqxx_no(aa,aa,i,i)) + else + bb=list_virt(b) + ! ia/ib + term=2.D0*(Fipq(aa,bb)+Fapq(aa,bb)) + term+=2.D0*(3.D0*bielec_pxxq_no(aa,i,i,bb)-bielec_pqxx_no(aa,bb,i,i)) + end if + else + ! ia/jb + jj=list_core(j) + bb=list_virt(b) + term=2.D0*(4.D0*bielec_pxxq_no(aa,i,j,bb)-bielec_pqxx_no(aa,bb,i,j) & + -bielec_pxxq_no(aa,j,i,bb)) + if (a.eq.b) then + term-=2.D0*(Fipq(ii,jj)+Fapq(ii,jj)) + end if + end if + term*=2.D0 + hessmat_iajb=term + +end function hessmat_iajb + +real*8 function hessmat_iatb(i,a,t,b) + BEGIN_DOC + ! the orbital hessian for core->virt,act->virt + END_DOC + implicit none + integer :: i,a,t,b,ii,aa,tt,bb,v,vv,x,y,v3,t3 + real*8 :: term + + ! write(6,*) ' hessmat_iatb ',i,a,t,b + ii=list_core(i) + aa=list_virt(a) + tt=list_act(t) + bb=list_virt(b) + t3=t+n_core_orb + term=occnum(tt)*(4.D0*bielec_pxxq_no(aa,i,t3,bb)-bielec_pxxq_no(aa,t3,i,bb)& + -bielec_pqxx_no(aa,bb,i,t3)) + if (a.eq.b) then + term-=Fipq(tt,ii)+Fapq(tt,ii) + term-=0.5D0*occnum(tt)*Fipq(tt,ii) + do v=1,n_act_orb + do x=1,n_act_orb + do y=1,n_act_orb + term-=P0tuvx_no(t,v,x,y)*bielecCI_no(x,y,v,ii) + end do + end do + end do + end if + term*=2.D0 + hessmat_iatb=term + +end function hessmat_iatb + +real*8 function hessmat_taub(t,a,u,b) + BEGIN_DOC + ! the orbital hessian for act->virt,act->virt + END_DOC + implicit none + integer :: t,a,u,b,tt,aa,uu,bb,v,vv,x,xx,y + integer :: v3,x3 + real*8 :: term,t1,t2,t3 + + tt=list_act(t) + aa=list_virt(a) + if (t.eq.u) then + if (a.eq.b) then + ! ta/ta + t1=occnum(tt)*Fipq(aa,aa) + t2=0.D0 + t3=0.D0 + t1-=occnum(tt)*Fipq(tt,tt) + do v=1,n_act_orb vv=list_act(v) v3=v+n_core_orb do x=1,n_act_orb -integer :: x3 - xx=list_act(x) - x3=x+n_core_orb - term-=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx(aa,ii,v3,x3) & - +(P0tuvx_no(t,v,u,x)+P0tuvx_no(t,v,x,u)) & - *bielec_pqxx(aa,xx,v3,i)) - end do - end do - if (t.eq.u) then - term+=Fipq(aa,ii)+Fapq(aa,ii) - end if - term*=2.D0 - hessmat_itua=term - - end function hessmat_itua - - real*8 function hessmat_iajb(i,a,j,b) -BEGIN_DOC -! the orbital hessian for core->virt,core->virt -END_DOC - implicit none - integer :: i,a,j,b,ii,aa,jj,bb - real*8 :: term -! write(6,*) ' hessmat_iajb ',i,a,j,b - - ii=list_core(i) - aa=list_virt(a) - if (i.eq.j) then - if (a.eq.b) then -! ia/ia - term=2.D0*(Fipq(aa,aa)+Fapq(aa,aa)-Fipq(ii,ii)-Fapq(ii,ii)) - term+=2.D0*(3.D0*bielec_pxxq(aa,i,i,aa)-bielec_pqxx(aa,aa,i,i)) - else - bb=list_virt(b) -! ia/ib - term=2.D0*(Fipq(aa,bb)+Fapq(aa,bb)) - term+=2.D0*(3.D0*bielec_pxxq(aa,i,i,bb)-bielec_pqxx(aa,bb,i,i)) - end if - else -! ia/jb - jj=list_core(j) - bb=list_virt(b) - term=2.D0*(4.D0*bielec_pxxq(aa,i,j,bb)-bielec_pqxx(aa,bb,i,j) & - -bielec_pxxq(aa,j,i,bb)) - if (a.eq.b) then - term-=2.D0*(Fipq(ii,jj)+Fapq(ii,jj)) - end if - end if - term*=2.D0 - hessmat_iajb=term - - end function hessmat_iajb - - real*8 function hessmat_iatb(i,a,t,b) -BEGIN_DOC -! the orbital hessian for core->virt,act->virt -END_DOC - implicit none - integer :: i,a,t,b,ii,aa,tt,bb,v,vv,x,y,v3,t3 - real*8 :: term - -! write(6,*) ' hessmat_iatb ',i,a,t,b - ii=list_core(i) - aa=list_virt(a) - tt=list_act(t) - bb=list_virt(b) - t3=t+n_core_orb - term=occnum(tt)*(4.D0*bielec_pxxq(aa,i,t3,bb)-bielec_pxxq(aa,t3,i,bb) & - -bielec_pqxx(aa,bb,i,t3)) - if (a.eq.b) then - term-=Fipq(tt,ii)+Fapq(tt,ii) - term-=0.5D0*occnum(tt)*Fipq(tt,ii) - do v=1,n_act_orb - do x=1,n_act_orb - do y=1,n_act_orb - term-=P0tuvx_no(t,v,x,y)*bielecCI(x,y,v,ii) - end do - end do - end do - end if - term*=2.D0 - hessmat_iatb=term - - end function hessmat_iatb - - real*8 function hessmat_taub(t,a,u,b) -BEGIN_DOC -! the orbital hessian for act->virt,act->virt -END_DOC - implicit none - integer :: t,a,u,b,tt,aa,uu,bb,v,vv,x,xx,y - integer :: v3,x3 - real*8 :: term,t1,t2,t3 - - tt=list_act(t) - aa=list_virt(a) - if (t.eq.u) then - if (a.eq.b) then -! ta/ta - t1=occnum(tt)*Fipq(aa,aa) - t2=0.D0 - t3=0.D0 - t1-=occnum(tt)*Fipq(tt,tt) - do v=1,n_act_orb - vv=list_act(v) - v3=v+n_core_orb - do x=1,n_act_orb - xx=list_act(x) - x3=x+n_core_orb - t2+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx(aa,aa,v3,x3) & - +(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* & - bielec_pxxq(aa,x3,v3,aa)) - do y=1,n_act_orb - t3-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI(t,v,y,xx) - end do - end do - end do - term=t1+t2+t3 -! write(6,*) ' Hess taub ',t,a,t1,t2,t3 - else - bb=list_virt(b) -! ta/tb b/=a - term=occnum(tt)*Fipq(aa,bb) - do v=1,n_act_orb - vv=list_act(v) - v3=v+n_core_orb - do x=1,n_act_orb - xx=list_act(x) - x3=x+n_core_orb - term+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx(aa,bb,v3,x3) & - +(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v)) & - *bielec_pxxq(aa,x3,v3,bb)) - end do - end do - end if - else -! ta/ub t/=u - uu=list_act(u) - bb=list_virt(b) - term=0.D0 - do v=1,n_act_orb - vv=list_act(v) - v3=v+n_core_orb - do x=1,n_act_orb xx=list_act(x) x3=x+n_core_orb - term+=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx(aa,bb,v3,x3) & - +(P0tuvx_no(t,x,v,u)+P0tuvx_no(t,x,u,v)) & - *bielec_pxxq(aa,x3,v3,bb)) - end do - end do - if (a.eq.b) then - term-=0.5D0*(occnum(tt)*Fipq(uu,tt)+occnum(uu)*Fipq(tt,uu)) - do v=1,n_act_orb - do x=1,n_act_orb - do y=1,n_act_orb - term-=P0tuvx_no(t,v,x,y)*bielecCI(x,y,v,uu) - term-=P0tuvx_no(u,v,x,y)*bielecCI(x,y,v,tt) - end do + t2+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx_no(aa,aa,v3,x3) & + +(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* & + bielec_pxxq_no(aa,x3,v3,aa)) + do y=1,n_act_orb + t3-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI_no(t,v,y,xx) end do - end do - end if - - end if - - term*=2.D0 - hessmat_taub=term - - end function hessmat_taub + end do + end do + term=t1+t2+t3 + ! write(6,*) ' Hess taub ',t,a,t1,t2,t3 + else + bb=list_virt(b) + ! ta/tb b/=a + term=occnum(tt)*Fipq(aa,bb) + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_orb + do x=1,n_act_orb + xx=list_act(x) + x3=x+n_core_orb + term+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx_no(aa,bb,v3,x3) & + +(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v)) & + *bielec_pxxq_no(aa,x3,v3,bb)) + end do + end do + end if + else + ! ta/ub t/=u + uu=list_act(u) + bb=list_virt(b) + term=0.D0 + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_orb + do x=1,n_act_orb + xx=list_act(x) + x3=x+n_core_orb + term+=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx_no(aa,bb,v3,x3) & + +(P0tuvx_no(t,x,v,u)+P0tuvx_no(t,x,u,v)) & + *bielec_pxxq_no(aa,x3,v3,bb)) + end do + end do + if (a.eq.b) then + term-=0.5D0*(occnum(tt)*Fipq(uu,tt)+occnum(uu)*Fipq(tt,uu)) + do v=1,n_act_orb + do x=1,n_act_orb + do y=1,n_act_orb + term-=P0tuvx_no(t,v,x,y)*bielecCI_no(x,y,v,uu) + term-=P0tuvx_no(u,v,x,y)*bielecCI_no(x,y,v,tt) + end do + end do + end do + end if + + end if + + term*=2.D0 + hessmat_taub=term + +end function hessmat_taub BEGIN_PROVIDER [real*8, hessdiag, (nMonoEx)] -BEGIN_DOC -! the diagonal of the Hessian, needed for the Davidson procedure -END_DOC - implicit none - integer :: i,t,a,indx - real*8 :: hessmat_itju,hessmat_iajb,hessmat_taub - - indx=0 - do i=1,n_core_orb - do t=1,n_act_orb - indx+=1 - hessdiag(indx)=hessmat_itju(i,t,i,t) - end do - end do - - do i=1,n_core_orb - do a=1,n_virt_orb - indx+=1 - hessdiag(indx)=hessmat_iajb(i,a,i,a) - end do - end do - - do t=1,n_act_orb - do a=1,n_virt_orb - indx+=1 - hessdiag(indx)=hessmat_taub(t,a,t,a) - end do - end do - + BEGIN_DOC + ! the diagonal of the Hessian, needed for the Davidson procedure + END_DOC + implicit none + integer :: i,t,a,indx + real*8 :: hessmat_itju,hessmat_iajb,hessmat_taub + + indx=0 + do i=1,n_core_orb + do t=1,n_act_orb + indx+=1 + hessdiag(indx)=hessmat_itju(i,t,i,t) + end do + end do + + do i=1,n_core_orb + do a=1,n_virt_orb + indx+=1 + hessdiag(indx)=hessmat_iajb(i,a,i,a) + end do + end do + + do t=1,n_act_orb + do a=1,n_virt_orb + indx+=1 + hessdiag(indx)=hessmat_taub(t,a,t,a) + end do + end do + END_PROVIDER diff --git a/src/casscf/mcscf_fock.irp.f b/src/casscf/mcscf_fock.irp.f index 301b1418..68845eb4 100644 --- a/src/casscf/mcscf_fock.irp.f +++ b/src/casscf/mcscf_fock.irp.f @@ -1,67 +1,80 @@ -! -*- F90 -*- - BEGIN_PROVIDER [real*8, Fipq, (mo_num,mo_num) ] -&BEGIN_PROVIDER [real*8, Fapq, (mo_num,mo_num) ] -BEGIN_DOC -! the inactive and the active Fock matrices, in molecular -! orbitals -! we create them in MOs, quite expensive -! -! for an implementation in AOs we need first the natural orbitals -! for forming an active density matrix in AOs -! -END_DOC - implicit none - double precision, allocatable :: integrals_array1(:,:) - double precision, allocatable :: integrals_array2(:,:) - integer :: p,q,k,kk,t,tt,u,uu - allocate(integrals_array1(mo_num,mo_num)) - allocate(integrals_array2(mo_num,mo_num)) - +BEGIN_PROVIDER [real*8, Fipq, (mo_num,mo_num) ] + BEGIN_DOC + ! the inactive Fock matrix, in molecular orbitals + END_DOC + implicit none + integer :: p,q,k,kk,t,tt,u,uu + + do q=1,mo_num + do p=1,mo_num + Fipq(p,q)=one_ints(p,q) + end do + end do + + ! the inactive Fock matrix + do k=1,n_core_orb + kk=list_core(k) + do q=1,mo_num do p=1,mo_num - do q=1,mo_num - Fipq(p,q)=one_ints(p,q) - Fapq(p,q)=0.D0 - end do + Fipq(p,q)+=2.D0*bielec_pqxx_no(p,q,k,k) -bielec_pxxq_no(p,k,k,q) end do - -! the inactive Fock matrix - do k=1,n_core_orb - kk=list_core(k) - do p=1,mo_num - do q=1,mo_num - Fipq(p,q)+=2.D0*bielec_pqxx(p,q,k,k) -bielec_pxxq(p,k,k,q) - end do - end do - end do - -! the active Fock matrix, D0tu is diagonal - do t=1,n_act_orb - tt=list_act(t) - do p=1,mo_num - do q=1,mo_num - Fapq(p,q)+=occnum(tt) & - *(bielec_pqxx(p,q,tt,tt)-0.5D0*bielec_pxxq(p,tt,tt,q)) - end do - end do - end do - -if (bavard) then -integer :: i - write(6,*) - write(6,*) ' the effective Fock matrix over MOs' - write(6,*) - - write(6,*) - write(6,*) ' the diagonal of the inactive effective Fock matrix ' - write(6,'(5(i3,F12.5))') (i,Fipq(i,i),i=1,mo_num) - write(6,*) - write(6,*) - write(6,*) ' the diagonal of the active Fock matrix ' - write(6,'(5(i3,F12.5))') (i,Fapq(i,i),i=1,mo_num) - write(6,*) -end if - - + end do + end do + + if (bavard) then + integer :: i + write(6,*) + write(6,*) ' the diagonal of the inactive effective Fock matrix ' + write(6,'(5(i3,F12.5))') (i,Fipq(i,i),i=1,mo_num) + write(6,*) + end if + + END_PROVIDER - - + + +BEGIN_PROVIDER [real*8, Fapq, (mo_num,mo_num) ] + BEGIN_DOC + ! the active active Fock matrix, in molecular orbitals + ! we create them in MOs, quite expensive + ! + ! for an implementation in AOs we need first the natural orbitals + ! for forming an active density matrix in AOs + ! + END_DOC + implicit none + integer :: p,q,k,kk,t,tt,u,uu + + Fapq = 0.d0 + + ! the active Fock matrix, D0tu is diagonal + do t=1,n_act_orb + tt=list_act(t) + do q=1,mo_num + do p=1,mo_num + Fapq(p,q)+=occnum(tt) & + *(bielec_pqxx_no(p,q,tt,tt)-0.5D0*bielec_pxxq_no(p,tt,tt,q)) + end do + end do + end do + + if (bavard) then + integer :: i + write(6,*) + write(6,*) ' the effective Fock matrix over MOs' + write(6,*) + + write(6,*) + write(6,*) ' the diagonal of the inactive effective Fock matrix ' + write(6,'(5(i3,F12.5))') (i,Fipq(i,i),i=1,mo_num) + write(6,*) + write(6,*) + write(6,*) ' the diagonal of the active Fock matrix ' + write(6,'(5(i3,F12.5))') (i,Fapq(i,i),i=1,mo_num) + write(6,*) + end if + + +END_PROVIDER + + diff --git a/src/casscf/natorb.irp.f b/src/casscf/natorb.irp.f index a903260c..d2cc6736 100644 --- a/src/casscf/natorb.irp.f +++ b/src/casscf/natorb.irp.f @@ -1,548 +1,373 @@ -! -*- F90 -*- -! diagonalize D0tu -! save the diagonal somewhere, in inverse order -! 4-index-transform the 2-particle density matrix over active orbitals -! correct the bielectronic integrals -! correct the monoelectronic integrals -! put integrals on file, as well orbitals, and the density matrices -! - subroutine trf_to_natorb - implicit none - integer :: i,j,k,l,t,u,p,q,pp - real*8 :: eigval(n_act_orb),natorbsCI(n_act_orb,n_act_orb) - real*8 :: d(n_act_orb),d1(n_act_orb),d2(n_act_orb) + BEGIN_PROVIDER [real*8, occnum, (mo_num)] + implicit none + BEGIN_DOC + ! MO occupation numbers + END_DOC + + integer :: i + occnum=0.D0 + do i=1,n_core_orb + occnum(list_core(i))=2.D0 + end do + + do i=1,n_act_orb + occnum(list_act(i))=occ_act(n_act_orb-i+1) + end do - call lapack_diag(eigval,natorbsCI,D0tu,n_act_orb,n_act_orb) - write(6,*) ' found occupation numbers as ' - do i=1,n_act_orb - write(6,*) i,eigval(i) - end do + write(6,*) ' occupation numbers ' + do i=1,mo_num + write(6,*) i,occnum(i) + end do - if (bavard) then -! - -integer :: nmx -real*8 :: xmx - do i=1,n_act_orb -! largest element of the eigenvector should be positive - xmx=0.D0 - nmx=0 - do j=1,n_act_orb - if (abs(natOrbsCI(j,i)).gt.xmx) then - nmx=j - xmx=abs(natOrbsCI(j,i)) - end if - end do - xmx=sign(1.D0,natOrbsCI(nmx,i)) - do j=1,n_act_orb - natOrbsCI(j,i)*=xmx - end do - - - write(6,*) ' Eigenvector No ',i - write(6,'(5(I3,F12.5))') (j,natOrbsCI(j,i),j=1,n_act_orb) - end do - end if - - do i=1,n_act_orb - do j=1,n_act_orb - D0tu(i,j)=0.D0 - end do -! fill occupation numbers in descending order - D0tu(i,i)=eigval(n_act_orb-i+1) - end do -! -! 4-index transformation of 2part matrices -! -! index per index -! first quarter - do j=1,n_act_orb - do k=1,n_act_orb - do l=1,n_act_orb - do p=1,n_act_orb - d(p)=0.D0 - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=P0tuvx(q,j,k,l)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - P0tuvx(p,j,k,l)=d(p) - end do - end do - end do - end do -! 2nd quarter - do j=1,n_act_orb - do k=1,n_act_orb - do l=1,n_act_orb - do p=1,n_act_orb - d(p)=0.D0 - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=P0tuvx(j,q,k,l)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - P0tuvx(j,p,k,l)=d(p) - end do - end do - end do - end do -! 3rd quarter - do j=1,n_act_orb - do k=1,n_act_orb - do l=1,n_act_orb - do p=1,n_act_orb - d(p)=0.D0 - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=P0tuvx(j,k,q,l)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - P0tuvx(j,k,p,l)=d(p) - end do - end do - end do - end do -! 4th quarter - do j=1,n_act_orb - do k=1,n_act_orb - do l=1,n_act_orb - do p=1,n_act_orb - d(p)=0.D0 - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=P0tuvx(j,k,l,q)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - P0tuvx(j,k,l,p)=d(p) - end do - end do - end do - end do - write(6,*) ' transformed P0tuvx ' -! -! one-electron integrals -! - do i=1,mo_num - do j=1,mo_num - onetrf(i,j)=mo_one_e_integrals(i,j) - end do - end do -! 1st half-trf - do j=1,mo_num - do p=1,n_act_orb - d(p)=0.D0 - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=onetrf(list_act(q),j)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - onetrf(list_act(p),j)=d(p) - end do - end do -! 2nd half-trf - do j=1,mo_num - do p=1,n_act_orb - d(p)=0.D0 - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=onetrf(j,list_act(q))*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - onetrf(j,list_act(p))=d(p) - end do - end do - write(6,*) ' transformed onetrf ' -! -! Orbitals -! - do j=1,ao_num - do i=1,mo_num - NatOrbsFCI(j,i)=mo_coef(j,i) - end do - end do - - do j=1,ao_num - do p=1,n_act_orb - d(p)=0.D0 - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=NatOrbsFCI(j,list_act(q))*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - NatOrbsFCI(j,list_act(p))=d(p) - end do - end do - write(6,*) ' transformed orbitals ' -! -! now the bielectronic integrals -! -!!$ write(6,*) ' before the transformation ' -!!$integer :: kk,ll,ii,jj -!!$real*8 :: h1,h2,h3 -!!$ do i=1,n_act_orb -!!$ ii=list_act(i) -!!$ do j=1,n_act_orb -!!$ jj=list_act(j) -!!$ do k=1,n_act_orb -!!$ kk=list_act(k) -!!$ do l=1,n_act_orb -!!$ ll=list_act(l) -!!$ h1=bielec_PQxxtmp(ii,jj,k+n_core_orb,l+n_core_orb) -!!$ h2=bielec_PxxQtmp(ii,j+n_core_orb,k+n_core_orb,ll) -!!$ h3=bielecCItmp(i,j,k,ll) -!!$ if ((h1.ne.h2).or.(h1.ne.h3)) then -!!$ write(6,9901) i,j,k,l,h1,h2,h3 -!!$9901 format(' aie ',4i4,3E20.12) -!!$9902 format('correct',4i4,3E20.12) -!!$ else -!!$ write(6,9902) i,j,k,l,h1,h2,h3 -!!$ end if -!!$ end do -!!$ end do -!!$ end do -!!$ end do - - do j=1,mo_num - do k=1,n_core_orb+n_act_orb - do l=1,n_core_orb+n_act_orb - do p=1,n_act_orb - d1(p)=0.D0 - d2(p)=0.D0 - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - do q=1,n_act_orb - d1(pp)+=bielec_PQxxtmp(list_act(q),j,k,l)*natorbsCI(q,p) - d2(pp)+=bielec_PxxQtmp(list_act(q),k,l,j)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - bielec_PQxxtmp(list_act(p),j,k,l)=d1(p) - bielec_PxxQtmp(list_act(p),k,l,j)=d2(p) - end do - end do - end do - end do -! 2nd quarter - do j=1,mo_num - do k=1,n_core_orb+n_act_orb - do l=1,n_core_orb+n_act_orb - do p=1,n_act_orb - d1(p)=0.D0 - d2(p)=0.D0 - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - do q=1,n_act_orb - d1(pp)+=bielec_PQxxtmp(j,list_act(q),k,l)*natorbsCI(q,p) - d2(pp)+=bielec_PxxQtmp(j,k,l,list_act(q))*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - bielec_PQxxtmp(j,list_act(p),k,l)=d1(p) - bielec_PxxQtmp(j,k,l,list_act(p))=d2(p) - end do - end do - end do - end do -! 3rd quarter - do j=1,mo_num - do k=1,mo_num - do l=1,n_core_orb+n_act_orb - do p=1,n_act_orb - d1(p)=0.D0 - d2(p)=0.D0 - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - do q=1,n_act_orb - d1(pp)+=bielec_PQxxtmp(j,k,n_core_orb+q,l)*natorbsCI(q,p) - d2(pp)+=bielec_PxxQtmp(j,n_core_orb+q,l,k)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - bielec_PQxxtmp(j,k,n_core_orb+p,l)=d1(p) - bielec_PxxQtmp(j,n_core_orb+p,l,k)=d2(p) - end do - end do - end do - end do -! 4th quarter - do j=1,mo_num - do k=1,mo_num - do l=1,n_core_orb+n_act_orb - do p=1,n_act_orb - d1(p)=0.D0 - d2(p)=0.D0 - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - do q=1,n_act_orb - d1(pp)+=bielec_PQxxtmp(j,k,l,n_core_orb+q)*natorbsCI(q,p) - d2(pp)+=bielec_PxxQtmp(j,l,n_core_orb+q,k)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - bielec_PQxxtmp(j,k,l,n_core_orb+p)=d1(p) - bielec_PxxQtmp(j,l,n_core_orb+p,k)=d2(p) - end do - end do - end do - end do - write(6,*) ' transformed PQxx and PxxQ ' -! -! and finally the bielecCI integrals -! - do j=1,n_act_orb - do k=1,n_act_orb - do l=1,mo_num - do p=1,n_act_orb - d(p)=0.D0 - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=bielecCItmp(q,j,k,l)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - bielecCItmp(p,j,k,l)=d(p) - end do - end do - end do - end do -! 2nd quarter - do j=1,n_act_orb - do k=1,n_act_orb - do l=1,mo_num - do p=1,n_act_orb - d(p)=0.D0 - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=bielecCItmp(j,q,k,l)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - bielecCItmp(j,p,k,l)=d(p) - end do - end do - end do - end do -! 3rd quarter - do j=1,n_act_orb - do k=1,n_act_orb - do l=1,mo_num - do p=1,n_act_orb - d(p)=0.D0 - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=bielecCItmp(j,k,q,l)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - bielecCItmp(j,k,p,l)=d(p) - end do - end do - end do - end do -! 4th quarter - do j=1,n_act_orb - do k=1,n_act_orb - do l=1,n_act_orb - do p=1,n_act_orb - d(p)=0.D0 - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=bielecCItmp(j,k,l,list_act(q))*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - bielecCItmp(j,k,l,list_act(p))=d(p) - end do - end do - end do - end do - write(6,*) ' transformed tuvP ' -! -! that's all -! -!!$ -!!$! test coherence of the bielectronic integals -!!$! PQxx = PxxQ = tuvP for some of the indices -!!$ write(6,*) ' after the transformation ' -!!$ do i=1,n_act_orb -!!$ ii=list_act(i) -!!$ do j=1,n_act_orb -!!$ jj=list_act(j) -!!$ do k=1,n_act_orb -!!$ kk=list_act(k) -!!$ do l=1,n_act_orb -!!$ ll=list_act(l) -!!$ h1=bielec_PQxxtmp(ii,jj,k+n_core_orb,l+n_core_orb) -!!$ h2=bielec_PxxQtmp(ii,j+n_core_orb,k+n_core_orb,ll) -!!$ h3=bielecCItmp(i,j,k,ll) -!!$ if ((abs(h1-h2).gt.1.D-14).or.(abs(h1-h3).gt.1.D-14)) then -!!$ write(6,9901) i,j,k,l,h1,h1-h2,h1-h3 -!!$ else -!!$ write(6,9902) i,j,k,l,h1,h2,h3 -!!$ end if -!!$ end do -!!$ end do -!!$ end do -!!$ end do - -! we recalculate total energies - write(6,*) - write(6,*) ' recalculating energies after the transformation ' - write(6,*) - write(6,*) - real*8 :: e_one_all - real*8 :: e_two_all - integer :: ii - integer :: jj - integer :: t3 - integer :: tt - integer :: u3 - integer :: uu - integer :: v - integer :: v3 - integer :: vv - integer :: x - integer :: x3 - integer :: xx - - e_one_all=0.D0 - e_two_all=0.D0 - do i=1,n_core_orb - ii=list_core(i) - e_one_all+=2.D0*onetrf(ii,ii) - do j=1,n_core_orb - jj=list_core(j) - e_two_all+=2.D0*bielec_PQxxtmp(ii,ii,j,j)-bielec_PQxxtmp(ii,jj,j,i) - end do - do t=1,n_act_orb - tt=list_act(t) - t3=t+n_core_orb - do u=1,n_act_orb - uu=list_act(u) - u3=u+n_core_orb - e_two_all+=D0tu(t,u)*(2.D0*bielec_PQxxtmp(tt,uu,i,i) & - -bielec_PQxxtmp(tt,ii,i,u3)) - end do - end do - end do - do t=1,n_act_orb - tt=list_act(t) - do u=1,n_act_orb - uu=list_act(u) - e_one_all+=D0tu(t,u)*onetrf(tt,uu) - do v=1,n_act_orb - v3=v+n_core_orb - do x=1,n_act_orb - x3=x+n_core_orb - e_two_all +=P0tuvx(t,u,v,x)*bielec_PQxxtmp(tt,uu,v3,x3) - end do - end do - end do - end do - write(6,*) ' e_one_all = ',e_one_all - write(6,*) ' e_two_all = ',e_two_all - ecore =nuclear_repulsion - ecore_bis=nuclear_repulsion - do i=1,n_core_orb - ii=list_core(i) - ecore +=2.D0*onetrf(ii,ii) - ecore_bis+=2.D0*onetrf(ii,ii) - do j=1,n_core_orb - jj=list_core(j) - ecore +=2.D0*bielec_PQxxtmp(ii,ii,j,j)-bielec_PQxxtmp(ii,jj,j,i) - ecore_bis+=2.D0*bielec_PxxQtmp(ii,i,j,jj)-bielec_PxxQtmp(ii,j,j,ii) - end do - end do - eone =0.D0 - eone_bis=0.D0 - etwo =0.D0 - etwo_bis=0.D0 - etwo_ter=0.D0 - do t=1,n_act_orb - tt=list_act(t) - t3=t+n_core_orb - do u=1,n_act_orb - uu=list_act(u) - u3=u+n_core_orb - eone +=D0tu(t,u)*onetrf(tt,uu) - eone_bis+=D0tu(t,u)*onetrf(tt,uu) - do i=1,n_core_orb - ii=list_core(i) - eone +=D0tu(t,u)*(2.D0*bielec_PQxxtmp(tt,uu,i,i) & - -bielec_PQxxtmp(tt,ii,i,u3)) - eone_bis+=D0tu(t,u)*(2.D0*bielec_PxxQtmp(tt,u3,i,ii) & - -bielec_PxxQtmp(tt,i,i,uu)) - end do - do v=1,n_act_orb - vv=list_act(v) - v3=v+n_core_orb - do x=1,n_act_orb - xx=list_act(x) - x3=x+n_core_orb -real*8 :: h1,h2,h3 - h1=bielec_PQxxtmp(tt,uu,v3,x3) - h2=bielec_PxxQtmp(tt,u3,v3,xx) - h3=bielecCItmp(t,u,v,xx) - etwo +=P0tuvx(t,u,v,x)*h1 - etwo_bis+=P0tuvx(t,u,v,x)*h2 - etwo_ter+=P0tuvx(t,u,v,x)*h3 - if ((abs(h1-h2).gt.1.D-14).or.(abs(h1-h3).gt.1.D-14)) then - write(6,9901) t,u,v,x,h1,h2,h3 -9901 format('aie: ',4I4,3E20.12) - end if - end do - end do - end do - end do - - write(6,*) ' energy contributions ' - write(6,*) ' core energy = ',ecore,' using PQxx integrals ' - write(6,*) ' core energy (bis) = ',ecore,' using PxxQ integrals ' - write(6,*) ' 1el energy = ',eone ,' using PQxx integrals ' - write(6,*) ' 1el energy (bis) = ',eone ,' using PxxQ integrals ' - write(6,*) ' 2el energy = ',etwo ,' using PQxx integrals ' - write(6,*) ' 2el energy (bis) = ',etwo_bis,' using PxxQ integrals ' - write(6,*) ' 2el energy (ter) = ',etwo_ter,' using tuvP integrals ' - write(6,*) ' ----------------------------------------- ' - write(6,*) ' sum of all = ',eone+etwo+ecore - write(6,*) - - end subroutine trf_to_natorb - - BEGIN_PROVIDER [real*8, onetrf, (mo_num,mo_num)] -&BEGIN_PROVIDER [real*8, NatOrbsFCI, (ao_num,mo_num)] END_PROVIDER + + + BEGIN_PROVIDER [ real*8, natorbsCI, (n_act_orb,n_act_orb) ] +&BEGIN_PROVIDER [ real*8, occ_act, (n_act_orb) ] + implicit none + BEGIN_DOC + ! Natural orbitals of CI + END_DOC + integer :: i, j + + call lapack_diag(occ_act,natorbsCI,D0tu,n_act_orb,n_act_orb) + + write(6,*) ' found occupation numbers as ' + do i=1,n_act_orb + write(6,*) i,occ_act(i) + end do + + if (bavard) then + ! + + integer :: nmx + real*8 :: xmx + do i=1,n_act_orb + ! largest element of the eigenvector should be positive + xmx=0.D0 + nmx=0 + do j=1,n_act_orb + if (abs(natOrbsCI(j,i)).gt.xmx) then + nmx=j + xmx=abs(natOrbsCI(j,i)) + end if + end do + xmx=sign(1.D0,natOrbsCI(nmx,i)) + do j=1,n_act_orb + natOrbsCI(j,i)*=xmx + end do + + write(6,*) ' Eigenvector No ',i + write(6,'(5(I3,F12.5))') (j,natOrbsCI(j,i),j=1,n_act_orb) + end do + end if + +END_PROVIDER + + +BEGIN_PROVIDER [real*8, P0tuvx_no, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + implicit none + BEGIN_DOC + ! 4-index transformation of 2part matrices + END_DOC + integer :: i,j,k,l,p,q,pp + real*8 :: d(n_act_orb) + + ! index per index + ! first quarter + P0tuvx_no(:,:,:,:) = P0tuvx(:,:,:,:) + + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=P0tuvx_no(q,j,k,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + P0tuvx_no(p,j,k,l)=d(p) + end do + end do + end do + end do + ! 2nd quarter + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=P0tuvx_no(j,q,k,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + P0tuvx_no(j,p,k,l)=d(p) + end do + end do + end do + end do + ! 3rd quarter + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=P0tuvx_no(j,k,q,l)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + P0tuvx_no(j,k,p,l)=d(p) + end do + end do + end do + end do + ! 4th quarter + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,n_act_orb + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=P0tuvx_no(j,k,l,q)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + P0tuvx_no(j,k,l,p)=d(p) + end do + end do + end do + end do + write(6,*) ' transformed P0tuvx ' + +END_PROVIDER + + + +BEGIN_PROVIDER [real*8, onetrf, (mo_num,mo_num)] + implicit none + BEGIN_DOC + ! Transformed one-e integrals + END_DOC + integer :: i,j, p, pp, q + real*8 :: d(n_act_orb) + onetrf(:,:)=mo_one_e_integrals(:,:) + + ! 1st half-trf + do j=1,mo_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=onetrf(list_act(q),j)*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + onetrf(list_act(p),j)=d(p) + end do + end do + + ! 2nd half-trf + do j=1,mo_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=onetrf(j,list_act(q))*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + onetrf(j,list_act(p))=d(p) + end do + end do + write(6,*) ' transformed onetrf ' +END_PROVIDER + + +BEGIN_PROVIDER [real*8, NatOrbsFCI, (ao_num,mo_num)] + implicit none + BEGIN_DOC +! FCI natural orbitals + END_DOC + integer :: i,j, p, pp, q + real*8 :: d(n_act_orb) + + NatOrbsFCI(:,:)=mo_coef(:,:) + + do j=1,ao_num + do p=1,n_act_orb + d(p)=0.D0 + end do + do p=1,n_act_orb + pp=n_act_orb-p+1 + do q=1,n_act_orb + d(pp)+=NatOrbsFCI(j,list_act(q))*natorbsCI(q,p) + end do + end do + do p=1,n_act_orb + NatOrbsFCI(j,list_act(p))=d(p) + end do + end do + write(6,*) ' transformed orbitals ' +END_PROVIDER + + + + + + +subroutine trf_to_natorb() + implicit none + BEGIN_DOC + ! save the diagonal somewhere, in inverse order + ! 4-index-transform the 2-particle density matrix over active orbitals + ! correct the bielectronic integrals + ! correct the monoelectronic integrals + ! put integrals on file, as well orbitals, and the density matrices + ! + END_DOC + integer :: i,j,k,l,t,u,p,q,pp + real*8 :: d(n_act_orb),d1(n_act_orb),d2(n_act_orb) + + ! we recalculate total energies + write(6,*) + write(6,*) ' recalculating energies after the transformation ' + write(6,*) + write(6,*) + real*8 :: e_one_all + real*8 :: e_two_all + integer :: ii + integer :: jj + integer :: t3 + integer :: tt + integer :: u3 + integer :: uu + integer :: v + integer :: v3 + integer :: vv + integer :: x + integer :: x3 + integer :: xx + + e_one_all=0.D0 + e_two_all=0.D0 + do i=1,n_core_orb + ii=list_core(i) + e_one_all+=2.D0*onetrf(ii,ii) + do j=1,n_core_orb + jj=list_core(j) + e_two_all+=2.D0*bielec_PQxx_no(ii,ii,j,j)-bielec_PQxx_no(ii,jj,j,i) + end do + do t=1,n_act_orb + tt=list_act(t) + t3=t+n_core_orb + e_two_all += occnum(list_act(t)) * & + (2.d0*bielec_PQxx_no(tt,tt,i,i) - bielec_PQxx_no(tt,ii,i,t3)) + end do + end do + + + + do t=1,n_act_orb + tt=list_act(t) + e_one_all += occnum(list_act(t))*onetrf(tt,tt) + do u=1,n_act_orb + uu=list_act(u) + do v=1,n_act_orb + v3=v+n_core_orb + do x=1,n_act_orb + x3=x+n_core_orb + e_two_all +=P0tuvx_no(t,u,v,x)*bielec_PQxx_no(tt,uu,v3,x3) + end do + end do + end do + end do + write(6,*) ' e_one_all = ',e_one_all + write(6,*) ' e_two_all = ',e_two_all + ecore =nuclear_repulsion + ecore_bis=nuclear_repulsion + do i=1,n_core_orb + ii=list_core(i) + ecore +=2.D0*onetrf(ii,ii) + ecore_bis+=2.D0*onetrf(ii,ii) + do j=1,n_core_orb + jj=list_core(j) + ecore +=2.D0*bielec_PQxx_no(ii,ii,j,j)-bielec_PQxx_no(ii,jj,j,i) + ecore_bis+=2.D0*bielec_PxxQ_no(ii,i,j,jj)-bielec_PxxQ_no(ii,j,j,ii) + end do + end do + eone =0.D0 + eone_bis=0.D0 + etwo =0.D0 + etwo_bis=0.D0 + etwo_ter=0.D0 + do t=1,n_act_orb + tt=list_act(t) + t3=t+n_core_orb + eone += occnum(list_act(t))*onetrf(tt,tt) + eone_bis += occnum(list_act(t))*onetrf(tt,tt) + do i=1,n_core_orb + ii=list_core(i) + eone += occnum(list_act(t)) * & + (2.D0*bielec_PQxx_no(tt,tt,i,i ) - bielec_PQxx_no(tt,ii,i,t3)) + eone_bis += occnum(list_act(t)) * & + (2.D0*bielec_PxxQ_no(tt,t3,i,ii) - bielec_PxxQ_no(tt,i ,i,tt)) + end do + do u=1,n_act_orb + uu=list_act(u) + u3=u+n_core_orb + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_orb + do x=1,n_act_orb + xx=list_act(x) + x3=x+n_core_orb + real*8 :: h1,h2,h3 + h1=bielec_PQxx_no(tt,uu,v3,x3) + h2=bielec_PxxQ_no(tt,u3,v3,xx) + h3=bielecCI_no(t,u,v,xx) + etwo +=P0tuvx_no(t,u,v,x)*h1 + etwo_bis+=P0tuvx_no(t,u,v,x)*h2 + etwo_ter+=P0tuvx_no(t,u,v,x)*h3 + if ((abs(h1-h2).gt.1.D-14).or.(abs(h1-h3).gt.1.D-14)) then + write(6,9901) t,u,v,x,h1,h2,h3 + 9901 format('aie: ',4I4,3E20.12) + end if + end do + end do + end do + end do + + write(6,*) ' energy contributions ' + write(6,*) ' core energy = ',ecore,' using PQxx integrals ' + write(6,*) ' core energy (bis) = ',ecore,' using PxxQ integrals ' + write(6,*) ' 1el energy = ',eone ,' using PQxx integrals ' + write(6,*) ' 1el energy (bis) = ',eone ,' using PxxQ integrals ' + write(6,*) ' 2el energy = ',etwo ,' using PQxx integrals ' + write(6,*) ' 2el energy (bis) = ',etwo_bis,' using PxxQ integrals ' + write(6,*) ' 2el energy (ter) = ',etwo_ter,' using tuvP integrals ' + write(6,*) ' ----------------------------------------- ' + write(6,*) ' sum of all = ',eone+etwo+ecore + write(6,*) + SOFT_TOUCH ecore ecore_bis eone eone_bis etwo etwo_bis etwo_ter + +end subroutine trf_to_natorb + diff --git a/src/casscf/natorb_casscf.irp.f b/src/casscf/natorb_casscf.irp.f deleted file mode 100644 index 0a818a34..00000000 --- a/src/casscf/natorb_casscf.irp.f +++ /dev/null @@ -1,65 +0,0 @@ -! -*- F90 -*- -BEGIN_PROVIDER [real*8, occnum, (mo_num)] - implicit none - integer :: i,kk,j - logical :: lread - real*8 :: rdum - do i=1,mo_num - occnum(i)=0.D0 - end do - do i=1,n_core_orb - occnum(list_core(i))=2.D0 - end do - - open(unit=12,file='D0tu.dat',form='formatted',status='old') - lread=.true. - do while (lread) - read(12,*,iostat=kk) i,j,rdum - if (kk.ne.0) then - lread=.false. - else - if (i.eq.j) then - occnum(list_act(i))=rdum - else - write(6,*) ' WARNING - no natural orbitals !' - write(6,*) i,j,rdum - end if - end if - end do - close(12) - write(6,*) ' read occupation numbers ' - do i=1,mo_num - write(6,*) i,occnum(i) - end do - -END_PROVIDER - -BEGIN_PROVIDER [real*8, P0tuvx_no, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] - implicit none - integer :: i,j,k,l,kk - real*8 :: rdum - logical :: lread - - do i=1,n_act_orb - do j=1,n_act_orb - do k=1,n_act_orb - do l=1,n_act_orb - P0tuvx_no(l,k,j,i)=0.D0 - end do - end do - end do - end do - - open(unit=12,file='P0tuvx.dat',form='formatted',status='old') - lread=.true. - do while (lread) - read(12,*,iostat=kk) i,j,k,l,rdum - if (kk.ne.0) then - lread=.false. - else - P0tuvx_no(i,j,k,l)=rdum - end if - end do - close(12) - write(6,*) ' read the 2-particle density matrix ' -END_PROVIDER diff --git a/src/casscf/tot_en.irp.f b/src/casscf/tot_en.irp.f index 8734006e..780cd543 100644 --- a/src/casscf/tot_en.irp.f +++ b/src/casscf/tot_en.irp.f @@ -1,4 +1,3 @@ -! -*- F90 -*- BEGIN_PROVIDER [real*8, etwo] &BEGIN_PROVIDER [real*8, eone] &BEGIN_PROVIDER [real*8, eone_bis] @@ -6,117 +5,117 @@ &BEGIN_PROVIDER [real*8, etwo_ter] &BEGIN_PROVIDER [real*8, ecore] &BEGIN_PROVIDER [real*8, ecore_bis] - implicit none - integer :: t,u,v,x,i,ii,tt,uu,vv,xx,j,jj,t3,u3,v3,x3 -real*8 :: e_one_all,e_two_all - e_one_all=0.D0 - e_two_all=0.D0 - do i=1,n_core_orb - ii=list_core(i) - e_one_all+=2.D0*mo_one_e_integrals(ii,ii) - do j=1,n_core_orb - jj=list_core(j) - e_two_all+=2.D0*bielec_PQxxtmp(ii,ii,j,j)-bielec_PQxxtmp(ii,jj,j,i) - end do - do t=1,n_act_orb - tt=list_act(t) - t3=t+n_core_orb - do u=1,n_act_orb - uu=list_act(u) - u3=u+n_core_orb - e_two_all+=D0tu(t,u)*(2.D0*bielec_PQxxtmp(tt,uu,i,i) & - -bielec_PQxxtmp(tt,ii,i,u3)) - end do - end do - end do - do t=1,n_act_orb - tt=list_act(t) - do u=1,n_act_orb - uu=list_act(u) - e_one_all+=D0tu(t,u)*mo_one_e_integrals(tt,uu) - do v=1,n_act_orb - v3=v+n_core_orb - do x=1,n_act_orb - x3=x+n_core_orb - e_two_all +=P0tuvx(t,u,v,x)*bielec_PQxxtmp(tt,uu,v3,x3) - end do - end do - end do - end do - write(6,*) ' e_one_all = ',e_one_all - write(6,*) ' e_two_all = ',e_two_all - ecore =nuclear_repulsion - ecore_bis=nuclear_repulsion - do i=1,n_core_orb - ii=list_core(i) - ecore +=2.D0*mo_one_e_integrals(ii,ii) - ecore_bis+=2.D0*mo_one_e_integrals(ii,ii) - do j=1,n_core_orb - jj=list_core(j) - ecore +=2.D0*bielec_PQxxtmp(ii,ii,j,j)-bielec_PQxxtmp(ii,jj,j,i) - ecore_bis+=2.D0*bielec_PxxQtmp(ii,i,j,jj)-bielec_PxxQtmp(ii,j,j,ii) - end do - end do - eone =0.D0 - eone_bis=0.D0 - etwo =0.D0 - etwo_bis=0.D0 - etwo_ter=0.D0 - do t=1,n_act_orb - tt=list_act(t) - t3=t+n_core_orb - do u=1,n_act_orb + implicit none + integer :: t,u,v,x,i,ii,tt,uu,vv,xx,j,jj,t3,u3,v3,x3 + real*8 :: e_one_all,e_two_all + e_one_all=0.D0 + e_two_all=0.D0 + do i=1,n_core_orb + ii=list_core(i) + e_one_all+=2.D0*mo_one_e_integrals(ii,ii) + do j=1,n_core_orb + jj=list_core(j) + e_two_all+=2.D0*bielec_PQxx(ii,ii,j,j)-bielec_PQxx(ii,jj,j,i) + end do + do t=1,n_act_orb + tt=list_act(t) + t3=t+n_core_orb + do u=1,n_act_orb uu=list_act(u) u3=u+n_core_orb - eone +=D0tu(t,u)*mo_one_e_integrals(tt,uu) - eone_bis+=D0tu(t,u)*mo_one_e_integrals(tt,uu) - do i=1,n_core_orb - ii=list_core(i) - eone +=D0tu(t,u)*(2.D0*bielec_PQxxtmp(tt,uu,i,i) & - -bielec_PQxxtmp(tt,ii,i,u3)) - eone_bis+=D0tu(t,u)*(2.D0*bielec_PxxQtmp(tt,u3,i,ii) & - -bielec_PxxQtmp(tt,i,i,uu)) + e_two_all+=D0tu(t,u)*(2.D0*bielec_PQxx(tt,uu,i,i) & + -bielec_PQxx(tt,ii,i,u3)) + end do + end do + end do + do t=1,n_act_orb + tt=list_act(t) + do u=1,n_act_orb + uu=list_act(u) + e_one_all+=D0tu(t,u)*mo_one_e_integrals(tt,uu) + do v=1,n_act_orb + v3=v+n_core_orb + do x=1,n_act_orb + x3=x+n_core_orb + e_two_all +=P0tuvx(t,u,v,x)*bielec_PQxx(tt,uu,v3,x3) end do - do v=1,n_act_orb - vv=list_act(v) - v3=v+n_core_orb - do x=1,n_act_orb + end do + end do + end do + write(6,*) ' e_one_all = ',e_one_all + write(6,*) ' e_two_all = ',e_two_all + ecore =nuclear_repulsion + ecore_bis=nuclear_repulsion + do i=1,n_core_orb + ii=list_core(i) + ecore +=2.D0*mo_one_e_integrals(ii,ii) + ecore_bis+=2.D0*mo_one_e_integrals(ii,ii) + do j=1,n_core_orb + jj=list_core(j) + ecore +=2.D0*bielec_PQxx(ii,ii,j,j)-bielec_PQxx(ii,jj,j,i) + ecore_bis+=2.D0*bielec_PxxQ(ii,i,j,jj)-bielec_PxxQ(ii,j,j,ii) + end do + end do + eone =0.D0 + eone_bis=0.D0 + etwo =0.D0 + etwo_bis=0.D0 + etwo_ter=0.D0 + do t=1,n_act_orb + tt=list_act(t) + t3=t+n_core_orb + do u=1,n_act_orb + uu=list_act(u) + u3=u+n_core_orb + eone +=D0tu(t,u)*mo_one_e_integrals(tt,uu) + eone_bis+=D0tu(t,u)*mo_one_e_integrals(tt,uu) + do i=1,n_core_orb + ii=list_core(i) + eone +=D0tu(t,u)*(2.D0*bielec_PQxx(tt,uu,i,i) & + -bielec_PQxx(tt,ii,i,u3)) + eone_bis+=D0tu(t,u)*(2.D0*bielec_PxxQ(tt,u3,i,ii) & + -bielec_PxxQ(tt,i,i,uu)) + end do + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_orb + do x=1,n_act_orb xx=list_act(x) x3=x+n_core_orb -real*8 :: h1,h2,h3 - h1=bielec_PQxxtmp(tt,uu,v3,x3) - h2=bielec_PxxQtmp(tt,u3,v3,xx) - h3=bielecCItmp(t,u,v,xx) + real*8 :: h1,h2,h3 + h1=bielec_PQxx(tt,uu,v3,x3) + h2=bielec_PxxQ(tt,u3,v3,xx) + h3=bielecCI(t,u,v,xx) etwo +=P0tuvx(t,u,v,x)*h1 etwo_bis+=P0tuvx(t,u,v,x)*h2 etwo_ter+=P0tuvx(t,u,v,x)*h3 if ((h1.ne.h2).or.(h1.ne.h3)) then - write(6,9901) t,u,v,x,h1,h2,h3 -9901 format('aie: ',4I4,3E20.12) + write(6,9901) t,u,v,x,h1,h2,h3 + 9901 format('aie: ',4I4,3E20.12) end if - end do end do - end do end do - - write(6,*) ' energy contributions ' - write(6,*) ' core energy = ',ecore,' using PQxx integrals ' - write(6,*) ' core energy (bis) = ',ecore,' using PxxQ integrals ' - write(6,*) ' 1el energy = ',eone ,' using PQxx integrals ' - write(6,*) ' 1el energy (bis) = ',eone ,' using PxxQ integrals ' - write(6,*) ' 2el energy = ',etwo ,' using PQxx integrals ' - write(6,*) ' 2el energy (bis) = ',etwo_bis,' using PxxQ integrals ' - write(6,*) ' 2el energy (ter) = ',etwo_ter,' using tuvP integrals ' - write(6,*) ' ----------------------------------------- ' - write(6,*) ' sum of all = ',eone+etwo+ecore - write(6,*) - write(6,*) ' nuclear (qp) = ',nuclear_repulsion - write(6,*) ' core energy (qp) = ',core_energy - write(6,*) ' 1el energy (qp) = ',psi_energy_h_core(1) - write(6,*) ' 2el energy (qp) = ',psi_energy_two_e(1) - write(6,*) ' nuc + 1 + 2 (qp) = ',nuclear_repulsion+psi_energy_h_core(1)+psi_energy_two_e(1) - write(6,*) ' <0|H|0> (qp) = ',psi_energy_with_nucl_rep(1) - + end do + end do + + write(6,*) ' energy contributions ' + write(6,*) ' core energy = ',ecore,' using PQxx integrals ' + write(6,*) ' core energy (bis) = ',ecore,' using PxxQ integrals ' + write(6,*) ' 1el energy = ',eone ,' using PQxx integrals ' + write(6,*) ' 1el energy (bis) = ',eone ,' using PxxQ integrals ' + write(6,*) ' 2el energy = ',etwo ,' using PQxx integrals ' + write(6,*) ' 2el energy (bis) = ',etwo_bis,' using PxxQ integrals ' + write(6,*) ' 2el energy (ter) = ',etwo_ter,' using tuvP integrals ' + write(6,*) ' ----------------------------------------- ' + write(6,*) ' sum of all = ',eone+etwo+ecore + write(6,*) + write(6,*) ' nuclear (qp) = ',nuclear_repulsion + write(6,*) ' core energy (qp) = ',core_energy + write(6,*) ' 1el energy (qp) = ',psi_energy_h_core(1) + write(6,*) ' 2el energy (qp) = ',psi_energy_two_e(1) + write(6,*) ' nuc + 1 + 2 (qp) = ',nuclear_repulsion+psi_energy_h_core(1)+psi_energy_two_e(1) + write(6,*) ' <0|H|0> (qp) = ',psi_energy_with_nucl_rep(1) + END_PROVIDER - - + + From 6531181316c131f30d54a3653d17b597c0a43f3b Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 25 Jun 2019 19:10:50 +0200 Subject: [PATCH 08/59] More cleaning --- src/casscf/casscf.irp.f | 8 +++++- src/casscf/driver_wdens.irp.f | 52 ----------------------------------- src/casscf/mcscf_fock.irp.f | 2 +- src/casscf/natorb.irp.f | 26 +++++++++--------- src/casscf/one_ints.irp.f | 26 ------------------ 5 files changed, 21 insertions(+), 93 deletions(-) delete mode 100644 src/casscf/driver_wdens.irp.f delete mode 100644 src/casscf/one_ints.irp.f diff --git a/src/casscf/casscf.irp.f b/src/casscf/casscf.irp.f index b55c4c3b..1737c852 100644 --- a/src/casscf/casscf.irp.f +++ b/src/casscf/casscf.irp.f @@ -19,7 +19,13 @@ subroutine run N_det = 1 TOUCH N_det psi_det psi_coef call run_cipsi - call driver_wdens + + write(6,*) ' total energy = ',eone+etwo+ecore + mo_label = "MCSCF" + mo_label = "Natural" + mo_coef(:,:) = NatOrbsFCI(:,:) + call save_mos + call driver_optorb energy_old = energy energy = eone+etwo+ecore diff --git a/src/casscf/driver_wdens.irp.f b/src/casscf/driver_wdens.irp.f deleted file mode 100644 index 5a3863a3..00000000 --- a/src/casscf/driver_wdens.irp.f +++ /dev/null @@ -1,52 +0,0 @@ - subroutine driver_wdens - implicit none - integer :: istate,p,q,r,s,indx,i,j - - - write(6,*) ' total energy = ',eone+etwo+ecore - write(6,*) ' generating natural orbitals ' - write(6,*) - write(6,*) - - write(6,*) ' all data available ! ' - write(6,*) ' writing out files ' - - call trf_to_natorb -real*8 :: approx,np,nq,nr,ns -logical :: lpq,lrs,lps,lqr - - open(unit=12,form='formatted',status='unknown',file='onetrf.tmp') - indx=0 - do q=1,mo_num - do p=q,mo_num - if (abs(onetrf(p,q)).gt.1.D-12) then - write(12,'(2i6,E20.12)') p,q,onetrf(p,q) - indx+=1 - end if - end do - end do - write(6,*) ' wrote ',indx,' mono-electronic integrals' - close(12) - - - write(6,*) - write(6,*) ' creating new orbitals ' - do i=1,mo_num - write(6,*) ' Orbital No ',i - write(6,'(5F14.6)') (NatOrbsFCI(j,i),j=1,mo_num) - write(6,*) - end do - - mo_label = "MCSCF" - mo_label = "Natural" - do i=1,mo_num - do j=1,ao_num - mo_coef(j,i)=NatOrbsFCI(j,i) - end do - end do - call save_mos - - write(6,*) ' ... done ' - - end - diff --git a/src/casscf/mcscf_fock.irp.f b/src/casscf/mcscf_fock.irp.f index 68845eb4..84b87248 100644 --- a/src/casscf/mcscf_fock.irp.f +++ b/src/casscf/mcscf_fock.irp.f @@ -7,7 +7,7 @@ BEGIN_PROVIDER [real*8, Fipq, (mo_num,mo_num) ] do q=1,mo_num do p=1,mo_num - Fipq(p,q)=one_ints(p,q) + Fipq(p,q)=one_ints_no(p,q) end do end do diff --git a/src/casscf/natorb.irp.f b/src/casscf/natorb.irp.f index d2cc6736..00c9564c 100644 --- a/src/casscf/natorb.irp.f +++ b/src/casscf/natorb.irp.f @@ -158,14 +158,14 @@ END_PROVIDER -BEGIN_PROVIDER [real*8, onetrf, (mo_num,mo_num)] +BEGIN_PROVIDER [real*8, one_ints_no, (mo_num,mo_num)] implicit none BEGIN_DOC ! Transformed one-e integrals END_DOC integer :: i,j, p, pp, q real*8 :: d(n_act_orb) - onetrf(:,:)=mo_one_e_integrals(:,:) + one_ints_no(:,:)=mo_one_e_integrals(:,:) ! 1st half-trf do j=1,mo_num @@ -175,11 +175,11 @@ BEGIN_PROVIDER [real*8, onetrf, (mo_num,mo_num)] do p=1,n_act_orb pp=n_act_orb-p+1 do q=1,n_act_orb - d(pp)+=onetrf(list_act(q),j)*natorbsCI(q,p) + d(pp)+=one_ints_no(list_act(q),j)*natorbsCI(q,p) end do end do do p=1,n_act_orb - onetrf(list_act(p),j)=d(p) + one_ints_no(list_act(p),j)=d(p) end do end do @@ -191,14 +191,14 @@ BEGIN_PROVIDER [real*8, onetrf, (mo_num,mo_num)] do p=1,n_act_orb pp=n_act_orb-p+1 do q=1,n_act_orb - d(pp)+=onetrf(j,list_act(q))*natorbsCI(q,p) + d(pp)+=one_ints_no(j,list_act(q))*natorbsCI(q,p) end do end do do p=1,n_act_orb - onetrf(j,list_act(p))=d(p) + one_ints_no(j,list_act(p))=d(p) end do end do - write(6,*) ' transformed onetrf ' + write(6,*) ' transformed one_ints ' END_PROVIDER @@ -271,7 +271,7 @@ subroutine trf_to_natorb() e_two_all=0.D0 do i=1,n_core_orb ii=list_core(i) - e_one_all+=2.D0*onetrf(ii,ii) + e_one_all+=2.D0*one_ints_no(ii,ii) do j=1,n_core_orb jj=list_core(j) e_two_all+=2.D0*bielec_PQxx_no(ii,ii,j,j)-bielec_PQxx_no(ii,jj,j,i) @@ -288,7 +288,7 @@ subroutine trf_to_natorb() do t=1,n_act_orb tt=list_act(t) - e_one_all += occnum(list_act(t))*onetrf(tt,tt) + e_one_all += occnum(list_act(t))*one_ints_no(tt,tt) do u=1,n_act_orb uu=list_act(u) do v=1,n_act_orb @@ -306,8 +306,8 @@ subroutine trf_to_natorb() ecore_bis=nuclear_repulsion do i=1,n_core_orb ii=list_core(i) - ecore +=2.D0*onetrf(ii,ii) - ecore_bis+=2.D0*onetrf(ii,ii) + ecore +=2.D0*one_ints_no(ii,ii) + ecore_bis+=2.D0*one_ints_no(ii,ii) do j=1,n_core_orb jj=list_core(j) ecore +=2.D0*bielec_PQxx_no(ii,ii,j,j)-bielec_PQxx_no(ii,jj,j,i) @@ -322,8 +322,8 @@ subroutine trf_to_natorb() do t=1,n_act_orb tt=list_act(t) t3=t+n_core_orb - eone += occnum(list_act(t))*onetrf(tt,tt) - eone_bis += occnum(list_act(t))*onetrf(tt,tt) + eone += occnum(list_act(t))*one_ints_no(tt,tt) + eone_bis += occnum(list_act(t))*one_ints_no(tt,tt) do i=1,n_core_orb ii=list_core(i) eone += occnum(list_act(t)) * & diff --git a/src/casscf/one_ints.irp.f b/src/casscf/one_ints.irp.f deleted file mode 100644 index a802f644..00000000 --- a/src/casscf/one_ints.irp.f +++ /dev/null @@ -1,26 +0,0 @@ -! -*- F90 -*- -BEGIN_PROVIDER [real*8, one_ints, (mo_num,mo_num)] - implicit none - integer :: i,j,kk - logical :: lread - real*8 :: rdum - do i=1,mo_num - do j=1,mo_num - one_ints(i,j)=0.D0 - end do - end do - open(unit=12,file='onetrf.tmp',status='old',form='formatted') - lread=.true. - do while (lread) - read(12,*,iostat=kk) i,j,rdum - if (kk.ne.0) then - lread=.false. - else - one_ints(i,j)=rdum - one_ints(j,i)=rdum - end if - end do - close(12) - write(6,*) ' read MCSCF natural one-electron integrals ' -END_PROVIDER - From 5902f3231eef21afffa86f40d75093c499748195 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 25 Jun 2019 23:10:19 +0200 Subject: [PATCH 09/59] Cleaned neworbs --- src/casscf/casscf.irp.f | 4 - src/casscf/neworbs.irp.f | 360 +++++++++++++++++---------------------- 2 files changed, 155 insertions(+), 209 deletions(-) diff --git a/src/casscf/casscf.irp.f b/src/casscf/casscf.irp.f index 1737c852..16c34131 100644 --- a/src/casscf/casscf.irp.f +++ b/src/casscf/casscf.irp.f @@ -21,10 +21,6 @@ subroutine run call run_cipsi write(6,*) ' total energy = ',eone+etwo+ecore - mo_label = "MCSCF" - mo_label = "Natural" - mo_coef(:,:) = NatOrbsFCI(:,:) - call save_mos call driver_optorb energy_old = energy diff --git a/src/casscf/neworbs.irp.f b/src/casscf/neworbs.irp.f index 6d63a86e..fd115880 100644 --- a/src/casscf/neworbs.irp.f +++ b/src/casscf/neworbs.irp.f @@ -1,222 +1,172 @@ -! -*- F90 -*- BEGIN_PROVIDER [real*8, SXmatrix, (nMonoEx+1,nMonoEx+1)] - implicit none - integer :: i,j - do i=1,nMonoEx+1 - do j=1,nMonoEx+1 - SXmatrix(i,j)=0.D0 - end do - end do - - do i=1,nMonoEx - SXmatrix(1,i+1)=gradvec2(i) - SXmatrix(1+i,1)=gradvec2(i) - end do - - do i=1,nMonoEx - do j=1,nMonoEx - SXmatrix(i+1,j+1)=hessmat2(i,j) - SXmatrix(j+1,i+1)=hessmat2(i,j) - end do - end do - - if (bavard) then - do i=2,nMonoEx+1 - write(6,*) ' diagonal of the Hessian : ',i,hessmat2(i,i) - end do - end if - - + implicit none + BEGIN_DOC + ! Single-excitation matrix + END_DOC + + integer :: i,j + + do i=1,nMonoEx+1 + do j=1,nMonoEx+1 + SXmatrix(i,j)=0.D0 + end do + end do + + do i=1,nMonoEx + SXmatrix(1,i+1)=gradvec2(i) + SXmatrix(1+i,1)=gradvec2(i) + end do + + do i=1,nMonoEx + do j=1,nMonoEx + SXmatrix(i+1,j+1)=hessmat2(i,j) + SXmatrix(j+1,i+1)=hessmat2(i,j) + end do + end do + + if (bavard) then + do i=2,nMonoEx+1 + write(6,*) ' diagonal of the Hessian : ',i,hessmat2(i,i) + end do + end if + + END_PROVIDER BEGIN_PROVIDER [real*8, SXeigenvec, (nMonoEx+1,nMonoEx+1)] &BEGIN_PROVIDER [real*8, SXeigenval, (nMonoEx+1)] - END_PROVIDER + implicit none + BEGIN_DOC + ! Eigenvectors/eigenvalues of the single-excitation matrix + END_DOC + call lapack_diag(SXeigenval,SXeigenvec,SXmatrix,nMonoEx+1,nMonoEx+1) +END_PROVIDER BEGIN_PROVIDER [real*8, SXvector, (nMonoEx+1)] &BEGIN_PROVIDER [real*8, energy_improvement] - implicit none - integer :: ierr,matz,i - real*8 :: c0 - - call lapack_diag(SXeigenval,SXeigenvec,SXmatrix,nMonoEx+1,nMonoEx+1) - write(6,*) ' SXdiag : lowest 5 eigenvalues ' - write(6,*) ' 1 - ',SXeigenval(1),SXeigenvec(1,1) - write(6,*) ' 2 - ',SXeigenval(2),SXeigenvec(1,2) - write(6,*) ' 3 - ',SXeigenval(3),SXeigenvec(1,3) - write(6,*) ' 4 - ',SXeigenval(4),SXeigenvec(1,4) - write(6,*) ' 5 - ',SXeigenval(5),SXeigenvec(1,5) - write(6,*) - write(6,*) ' SXdiag : lowest eigenvalue = ',SXeigenval(1) - energy_improvement = SXeigenval(1) - -integer :: best_vector -real*8 :: best_overlap - best_overlap=0.D0 - do i=1,nMonoEx+1 - if (SXeigenval(i).lt.0.D0) then - if (abs(SXeigenvec(1,i)).gt.best_overlap) then - best_overlap=abs(SXeigenvec(1,i)) - best_vector=i - end if - end if - end do - - write(6,*) ' SXdiag : eigenvalue for best overlap with ' - write(6,*) ' previous orbitals = ',SXeigenval(best_vector) - energy_improvement = SXeigenval(best_vector) - - c0=SXeigenvec(1,best_vector) - write(6,*) ' weight of the 1st element ',c0 - do i=1,nMonoEx+1 - SXvector(i)=SXeigenvec(i,best_vector)/c0 -! write(6,*) ' component No ',i,' : ',SXvector(i) - end do - + implicit none + BEGIN_DOC + ! Best eigenvector of the single-excitation matrix + END_DOC + integer :: ierr,matz,i + real*8 :: c0 + + write(6,*) ' SXdiag : lowest 5 eigenvalues ' + write(6,*) ' 1 - ',SXeigenval(1),SXeigenvec(1,1) + write(6,*) ' 2 - ',SXeigenval(2),SXeigenvec(1,2) + write(6,*) ' 3 - ',SXeigenval(3),SXeigenvec(1,3) + write(6,*) ' 4 - ',SXeigenval(4),SXeigenvec(1,4) + write(6,*) ' 5 - ',SXeigenval(5),SXeigenvec(1,5) + write(6,*) + write(6,*) ' SXdiag : lowest eigenvalue = ',SXeigenval(1) + energy_improvement = SXeigenval(1) + + integer :: best_vector + real*8 :: best_overlap + best_overlap=0.D0 + do i=1,nMonoEx+1 + if (SXeigenval(i).lt.0.D0) then + if (abs(SXeigenvec(1,i)).gt.best_overlap) then + best_overlap=abs(SXeigenvec(1,i)) + best_vector=i + end if + end if + end do + + write(6,*) ' SXdiag : eigenvalue for best overlap with ' + write(6,*) ' previous orbitals = ',SXeigenval(best_vector) + energy_improvement = SXeigenval(best_vector) + + c0=SXeigenvec(1,best_vector) + write(6,*) ' weight of the 1st element ',c0 + do i=1,nMonoEx+1 + SXvector(i)=SXeigenvec(i,best_vector)/c0 + ! write(6,*) ' component No ',i,' : ',SXvector(i) + end do + END_PROVIDER BEGIN_PROVIDER [real*8, NewOrbs, (ao_num,mo_num) ] - implicit none - integer :: i,j,ialph - -! form the exponential of the Orbital rotations - call get_orbrotmat -! form the new orbitals - do i=1,ao_num - do j=1,mo_num - NewOrbs(i,j)=0.D0 - end do - end do - - do ialph=1,ao_num - do i=1,mo_num - wrkline(i)=mo_coef(ialph,i) - end do - do i=1,mo_num - do j=1,mo_num - NewOrbs(ialph,i)+=Umat(i,j)*wrkline(j) - end do - end do - end do - + implicit none + BEGIN_DOC + ! Updated orbitals + END_DOC + integer :: i,j,ialph + + call dgemm('N','T', ao_num,mo_num,mo_num,1.d0, & + NatOrbsFCI, size(NatOrbsFCI,1), & + Umat, size(Umat,1), 0.d0, & + NewOrbs, size(NewOrbs,1)) + END_PROVIDER - BEGIN_PROVIDER [real*8, Tpotmat, (mo_num,mo_num) ] -&BEGIN_PROVIDER [real*8, Umat, (mo_num,mo_num) ] -&BEGIN_PROVIDER [real*8, wrkline, (mo_num) ] -&BEGIN_PROVIDER [real*8, Tmat, (mo_num,mo_num) ] -END_PROVIDER - - subroutine get_orbrotmat - implicit none - integer :: i,j,indx,k,iter,t,a,ii,tt,aa - real*8 :: sum - logical :: converged - - -! the orbital rotation matrix T - do i=1,mo_num - do j=1,mo_num - Tmat(i,j)=0.D0 - Umat(i,j)=0.D0 - Tpotmat(i,j)=0.D0 - end do - Tpotmat(i,i)=1.D0 - end do - - indx=1 - do i=1,n_core_orb - ii=list_core(i) - do t=1,n_act_orb - tt=list_act(t) - indx+=1 - Tmat(ii,tt)= SXvector(indx) - Tmat(tt,ii)=-SXvector(indx) - end do - end do - do i=1,n_core_orb - ii=list_core(i) - do a=1,n_virt_orb - aa=list_virt(a) - indx+=1 - Tmat(ii,aa)= SXvector(indx) - Tmat(aa,ii)=-SXvector(indx) - end do - end do - do t=1,n_act_orb - tt=list_act(t) - do a=1,n_virt_orb - aa=list_virt(a) - indx+=1 - Tmat(tt,aa)= SXvector(indx) - Tmat(aa,tt)=-SXvector(indx) - end do - end do - - write(6,*) ' the T matrix ' - do indx=1,nMonoEx - i=excit(1,indx) - j=excit(2,indx) -! if (abs(Tmat(i,j)).gt.1.D0) then -! write(6,*) ' setting matrix element ',i,j,' of ',Tmat(i,j),' to ' & -! , sign(1.D0,Tmat(i,j)) -! Tmat(i,j)=sign(1.D0,Tmat(i,j)) -! Tmat(j,i)=-Tmat(i,j) -! end if - if (abs(Tmat(i,j)).gt.1.D-9) write(6,9901) i,j,excit_class(indx),Tmat(i,j) - 9901 format(' ',i4,' -> ',i4,' (',A3,') : ',E14.6) - end do - - write(6,*) - write(6,*) ' forming the matrix exponential ' - write(6,*) -! form the exponential - iter=0 - converged=.false. - do while (.not.converged) - iter+=1 -! add the next term - do i=1,mo_num - do j=1,mo_num - Umat(i,j)+=Tpotmat(i,j) - end do - end do -! next power of T, we multiply Tpotmat with Tmat/iter - do i=1,mo_num - do j=1,mo_num - wrkline(j)=Tpotmat(i,j)/dble(iter) - Tpotmat(i,j)=0.D0 - end do - do j=1,mo_num - do k=1,mo_num - Tpotmat(i,j)+=wrkline(k)*Tmat(k,j) - end do - end do - end do -! Convergence test - sum=0.D0 - do i=1,mo_num - do j=1,mo_num - sum+=abs(Tpotmat(i,j)) - end do - end do - write(6,*) ' Iteration No ',iter,' Sum = ',sum - if (sum.lt.1.D-6) then - converged=.true. - end if - if (iter.ge.NItExpMax) then - stop ' no convergence ' - end if - end do - write(6,*) - write(6,*) ' Converged ! ' - write(6,*) - - end subroutine get_orbrotmat - -BEGIN_PROVIDER [integer, NItExpMax] - NItExpMax=100 +BEGIN_PROVIDER [real*8, Umat, (mo_num,mo_num) ] + implicit none + BEGIN_DOC + ! Orbital rotation matrix + END_DOC + integer :: i,j,indx,k,iter,t,a,ii,tt,aa + logical :: converged + + real*8 :: Tpotmat (mo_num,mo_num), Tpotmat2 (mo_num,mo_num) + real*8 :: Tmat(mo_num,mo_num) + real*8 :: f + + ! the orbital rotation matrix T + Tmat(:,:)=0.D0 + indx=1 + do i=1,n_core_orb + ii=list_core(i) + do t=1,n_act_orb + tt=list_act(t) + indx+=1 + Tmat(ii,tt)= SXvector(indx) + Tmat(tt,ii)=-SXvector(indx) + end do + end do + do i=1,n_core_orb + ii=list_core(i) + do a=1,n_virt_orb + aa=list_virt(a) + indx+=1 + Tmat(ii,aa)= SXvector(indx) + Tmat(aa,ii)=-SXvector(indx) + end do + end do + do t=1,n_act_orb + tt=list_act(t) + do a=1,n_virt_orb + aa=list_virt(a) + indx+=1 + Tmat(tt,aa)= SXvector(indx) + Tmat(aa,tt)=-SXvector(indx) + end do + end do + + ! Form the exponential + + Tpotmat(:,:)=0.D0 + Umat(:,:) =0.D0 + do i=1,mo_num + Tpotmat(i,i)=1.D0 + Umat(i,i) =1.d0 + end do + iter=0 + converged=.false. + do while (.not.converged) + iter+=1 + f = 1.d0 / dble(iter) + Tpotmat2(:,:) = Tpotmat(:,:) * f + call dgemm('N','N', mo_num,mo_num,mo_num,1.d0, & + Tpotmat2, size(Tpotmat2,1), & + Tmat, size(Tmat,1), 0.d0, & + Tpotmat, size(Tpotmat,1)) + Umat(:,:) = Umat(:,:) + Tpotmat(:,:) + + converged = ( sum(abs(Tpotmat(:,:))) < 1.d-6).or.(iter>30) + end do END_PROVIDER + From a128c20afa8a3ed8573604f7e06130087e3bd6f3 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 26 Jun 2019 00:51:47 +0200 Subject: [PATCH 10/59] CASSCF works --- src/casscf/bielec.irp.f | 3 - src/casscf/bielec_natorb.irp.f | 3 - src/casscf/casscf.irp.f | 28 ++++-- src/casscf/densities.irp.f | 8 +- src/casscf/driver_optorb.irp.f | 35 +------ src/casscf/gradient.irp.f | 23 ++--- src/casscf/hessian.irp.f | 23 ++--- src/casscf/natorb.irp.f | 167 +++------------------------------ src/casscf/neworbs.irp.f | 30 +++--- src/casscf/tot_en.irp.f | 20 ---- 10 files changed, 76 insertions(+), 264 deletions(-) diff --git a/src/casscf/bielec.irp.f b/src/casscf/bielec.irp.f index 9bb953f8..74351760 100644 --- a/src/casscf/bielec.irp.f +++ b/src/casscf/bielec.irp.f @@ -55,7 +55,6 @@ end do end do - write(6,*) ' provided integrals (PQ|xx) ' END_PROVIDER @@ -116,7 +115,6 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_a end do end do end do - write(6,*) ' provided integrals (Px|xQ) ' END_PROVIDER @@ -146,6 +144,5 @@ BEGIN_PROVIDER [real*8, bielecCI, (n_act_orb,n_act_orb,n_act_orb, mo_num)] end do end do end do - write(6,*) ' provided integrals (tu|xP) ' END_PROVIDER diff --git a/src/casscf/bielec_natorb.irp.f b/src/casscf/bielec_natorb.irp.f index 2f1e43eb..ca1c8e9d 100644 --- a/src/casscf/bielec_natorb.irp.f +++ b/src/casscf/bielec_natorb.irp.f @@ -84,7 +84,6 @@ end do end do end do - write(6,*) ' transformed PQxx' END_PROVIDER @@ -176,7 +175,6 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_orb+n_act_orb,n_core_orb+ end do end do end do - write(6,*) ' transformed PxxQ ' END_PROVIDER @@ -267,7 +265,6 @@ BEGIN_PROVIDER [real*8, bielecCI_no, (n_act_orb,n_act_orb,n_act_orb, mo_num)] end do end do end do - write(6,*) ' transformed tuvP ' END_PROVIDER diff --git a/src/casscf/casscf.irp.f b/src/casscf/casscf.irp.f index 16c34131..10a3e34a 100644 --- a/src/casscf/casscf.irp.f +++ b/src/casscf/casscf.irp.f @@ -12,20 +12,32 @@ subroutine run implicit none double precision :: energy_old, energy logical :: converged + integer :: iteration converged = .False. energy = 0.d0 -! do while (.not.converged) - N_det = 1 - TOUCH N_det psi_det psi_coef + mo_label = "MCSCF" + iteration = 1 + do while (.not.converged) call run_cipsi - write(6,*) ' total energy = ',eone+etwo+ecore - - call driver_optorb energy_old = energy energy = eone+etwo+ecore - converged = dabs(energy - energy_old) < 1.d-10 -! enddo + + call write_time(6) + call write_int(6,iteration,'CAS-SCF iteration') + call write_double(6,energy,'CAS-SCF energy') + call write_double(6,energy_improvement, 'Predicted energy improvement') + + converged = dabs(energy_improvement) < thresh_scf + + mo_coef = NewOrbs + call save_mos + call map_deinit(mo_integrals_map) + N_det = 1 + iteration += 1 + FREE mo_integrals_map mo_two_e_integrals_in_map psi_det psi_coef + SOFT_TOUCH mo_coef N_det + enddo end diff --git a/src/casscf/densities.irp.f b/src/casscf/densities.irp.f index 6e8065e2..8be2db6e 100644 --- a/src/casscf/densities.irp.f +++ b/src/casscf/densities.irp.f @@ -22,7 +22,9 @@ BEGIN_PROVIDER [real*8, D0tu, (n_act_orb,n_act_orb) ] integer :: ierr1,ierr2 real*8 :: cI_mu(N_states) - write(6,*) ' providing density matrices D0 and P0 ' + if (bavard) then + write(6,*) ' providing density matrix D0' + endif D0tu = 0.d0 @@ -90,7 +92,9 @@ BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ] integer(bit_kind), dimension(N_int,2) :: det_mu_ex1, det_mu_ex11, det_mu_ex12 integer(bit_kind), dimension(N_int,2) :: det_mu_ex2, det_mu_ex21, det_mu_ex22 - write(6,*) ' providing density matrices D0 and P0 ' + if (bavard) then + write(6,*) ' providing density matrix P0' + endif P0tuvx = 0.d0 diff --git a/src/casscf/driver_optorb.irp.f b/src/casscf/driver_optorb.irp.f index 591c90c9..2e3e02dc 100644 --- a/src/casscf/driver_optorb.irp.f +++ b/src/casscf/driver_optorb.irp.f @@ -1,32 +1,3 @@ - subroutine driver_optorb - implicit none - integer :: i,j - - write(6,*) -! write(6,*) ' <0|H|0> (qp) = ',psi_energy_with_nucl_rep(1) - write(6,*) ' energy improvement = ',energy_improvement -! write(6,*) ' new energy = ',psi_energy_with_nucl_rep(1)+energy_improvement - write(6,*) - - write(6,*) - write(6,*) ' creating new orbitals ' - do i=1,mo_num - write(6,*) ' Orbital No ',i - write(6,'(5F14.6)') (NewOrbs(j,i),j=1,mo_num) - write(6,*) - end do - - mo_label = "Natural" - do i=1,mo_num - do j=1,ao_num - mo_coef(j,i)=NewOrbs(j,i) - end do - end do - call save_mos - call map_deinit(mo_integrals_map) - FREE mo_integrals_map mo_coef mo_two_e_integrals_in_map - - write(6,*) - write(6,*) ' ... all done ' - - end +subroutine driver_optorb + implicit none +end diff --git a/src/casscf/gradient.irp.f b/src/casscf/gradient.irp.f index 606bf12b..883a4665 100644 --- a/src/casscf/gradient.irp.f +++ b/src/casscf/gradient.irp.f @@ -6,7 +6,6 @@ BEGIN_PROVIDER [ integer, nMonoEx ] END_DOC implicit none nMonoEx=n_core_orb*n_act_orb+n_core_orb*n_virt_orb+n_act_orb*n_virt_orb - write(6,*) ' nMonoEx = ',nMonoEx END_PROVIDER BEGIN_PROVIDER [integer, excit, (2,nMonoEx)] @@ -87,9 +86,11 @@ BEGIN_PROVIDER [real*8, gradvec, (nMonoEx)] norm_grad+=gradvec(indx)*gradvec(indx) end do norm_grad=sqrt(norm_grad) - write(6,*) - write(6,*) ' Norm of the orbital gradient (via <0|EH|0>) : ', norm_grad - write(6,*) + if (bavard) then + write(6,*) + write(6,*) ' Norm of the orbital gradient (via <0|EH|0>) : ', norm_grad + write(6,*) + endif END_PROVIDER @@ -118,17 +119,11 @@ subroutine calc_grad_elem(ihole,ipart,res) call do_signed_mono_excitation(det_mu,det_mu_ex,nu & ,ihole,ipart,ispin,phase,ierr) if (ierr.eq.1) then - ! write(6,*) - ! write(6,*) ' mu = ',mu - ! call print_det(det_mu,N_int) - ! write(6,*) ' generated nu = ',nu,' for excitation ',ihole,' -> ',ipart,' ierr = ',ierr,' phase = ',phase,' ispin = ',ispin - ! call print_det(det_mu_ex,N_int) call i_H_psi(det_mu_ex,psi_det,psi_coef,N_int & ,N_det,N_det,N_states,i_H_psi_array) do istate=1,N_states res+=i_H_psi_array(istate)*psi_coef(mu,istate)*phase end do - ! write(6,*) ' contribution = ',i_H_psi_array(1)*psi_coef(mu,1)*phase,res end if end do end do @@ -176,9 +171,11 @@ BEGIN_PROVIDER [real*8, gradvec2, (nMonoEx)] norm_grad+=gradvec2(indx)*gradvec2(indx) end do norm_grad=sqrt(norm_grad) - write(6,*) - write(6,*) ' Norm of the orbital gradient (via D, P and integrals): ', norm_grad - write(6,*) + if (bavard) then + write(6,*) + write(6,*) ' Norm of the orbital gradient (via D, P and integrals): ', norm_grad + write(6,*) + endif END_PROVIDER diff --git a/src/casscf/hessian.irp.f b/src/casscf/hessian.irp.f index 65734a25..e047c5fd 100644 --- a/src/casscf/hessian.irp.f +++ b/src/casscf/hessian.irp.f @@ -14,8 +14,10 @@ BEGIN_PROVIDER [real*8, hessmat, (nMonoEx,nMonoEx)] character*3 :: iexc,jexc real*8 :: res - write(6,*) ' providing Hessian matrix hessmat ' - write(6,*) ' nMonoEx = ',nMonoEx + if (bavard) then + write(6,*) ' providing Hessian matrix hessmat ' + write(6,*) ' nMonoEx = ',nMonoEx + endif do indx=1,nMonoEx do jndx=1,nMonoEx @@ -32,8 +34,6 @@ BEGIN_PROVIDER [real*8, hessmat, (nMonoEx,nMonoEx)] jpart=excit(2,jndx) jexc=excit_class(jndx) call calc_hess_elem(ihole,ipart,jhole,jpart,res) - ! write(6,*) ' Hessian ',ihole,'->',ipart & - ! ,' (',iexc,')',jhole,'->',jpart,' (',jexc,')',res hessmat(indx,jndx)=res hessmat(jndx,indx)=res end do @@ -198,8 +198,10 @@ BEGIN_PROVIDER [real*8, hessmat2, (nMonoEx,nMonoEx)] real*8 :: hessmat_iatb real*8 :: hessmat_taub - write(6,*) ' providing Hessian matrix hessmat2 ' - write(6,*) ' nMonoEx = ',nMonoEx + if (bavard) then + write(6,*) ' providing Hessian matrix hessmat2 ' + write(6,*) ' nMonoEx = ',nMonoEx + endif indx=1 do i=1,n_core_orb @@ -214,7 +216,6 @@ BEGIN_PROVIDER [real*8, hessmat2, (nMonoEx,nMonoEx)] do u=ustart,n_act_orb hessmat2(indx,jndx)=hessmat_itju(i,t,j,u) hessmat2(jndx,indx)=hessmat2(indx,jndx) - ! write(6,*) ' result I :',i,t,j,u,indx,jndx,hessmat(indx,jndx),hessmat2(indx,jndx) jndx+=1 end do end do @@ -294,7 +295,6 @@ real*8 function hessmat_itju(i,t,j,u) integer :: i,t,j,u,ii,tt,uu,v,vv,x,xx,y,jj real*8 :: term,t2 - ! write(6,*) ' hessmat_itju ',i,t,j,u ii=list_core(i) tt=list_act(t) if (i.eq.j) then @@ -340,8 +340,6 @@ real*8 function hessmat_itju(i,t,j,u) end do end do end do - !!! write(6,*) ' direct diff ',i,t,j,u,term,term2 - !!! term=term2 end if else ! it/ju @@ -382,7 +380,6 @@ real*8 function hessmat_itja(i,t,j,a) integer :: i,t,j,a,ii,tt,jj,aa,v,vv,x,y real*8 :: term - ! write(6,*) ' hessmat_itja ',i,t,j,a ! it/ja ii=list_core(i) tt=list_act(t) @@ -416,7 +413,6 @@ real*8 function hessmat_itua(i,t,u,a) integer :: i,t,u,a,ii,tt,uu,aa,v,vv,x,xx,u3,t3,v3 real*8 :: term - ! write(6,*) ' hessmat_itua ',i,t,u,a ii=list_core(i) tt=list_act(t) t3=t+n_core_orb @@ -457,7 +453,6 @@ real*8 function hessmat_iajb(i,a,j,b) implicit none integer :: i,a,j,b,ii,aa,jj,bb real*8 :: term - ! write(6,*) ' hessmat_iajb ',i,a,j,b ii=list_core(i) aa=list_virt(a) @@ -495,7 +490,6 @@ real*8 function hessmat_iatb(i,a,t,b) integer :: i,a,t,b,ii,aa,tt,bb,v,vv,x,y,v3,t3 real*8 :: term - ! write(6,*) ' hessmat_iatb ',i,a,t,b ii=list_core(i) aa=list_virt(a) tt=list_act(t) @@ -552,7 +546,6 @@ real*8 function hessmat_taub(t,a,u,b) end do end do term=t1+t2+t3 - ! write(6,*) ' Hess taub ',t,a,t1,t2,t3 else bb=list_virt(b) ! ta/tb b/=a diff --git a/src/casscf/natorb.irp.f b/src/casscf/natorb.irp.f index 00c9564c..52cd3747 100644 --- a/src/casscf/natorb.irp.f +++ b/src/casscf/natorb.irp.f @@ -14,10 +14,12 @@ occnum(list_act(i))=occ_act(n_act_orb-i+1) end do - write(6,*) ' occupation numbers ' - do i=1,mo_num - write(6,*) i,occnum(i) - end do + if (bavard) then + write(6,*) ' occupation numbers ' + do i=1,mo_num + write(6,*) i,occnum(i) + end do + endif END_PROVIDER @@ -32,14 +34,12 @@ END_PROVIDER call lapack_diag(occ_act,natorbsCI,D0tu,n_act_orb,n_act_orb) - write(6,*) ' found occupation numbers as ' - do i=1,n_act_orb - write(6,*) i,occ_act(i) - end do - if (bavard) then - ! - + write(6,*) ' found occupation numbers as ' + do i=1,n_act_orb + write(6,*) i,occ_act(i) + end do + integer :: nmx real*8 :: xmx do i=1,n_act_orb @@ -152,7 +152,6 @@ BEGIN_PROVIDER [real*8, P0tuvx_no, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] end do end do end do - write(6,*) ' transformed P0tuvx ' END_PROVIDER @@ -198,7 +197,6 @@ BEGIN_PROVIDER [real*8, one_ints_no, (mo_num,mo_num)] one_ints_no(j,list_act(p))=d(p) end do end do - write(6,*) ' transformed one_ints ' END_PROVIDER @@ -226,148 +224,5 @@ BEGIN_PROVIDER [real*8, NatOrbsFCI, (ao_num,mo_num)] NatOrbsFCI(j,list_act(p))=d(p) end do end do - write(6,*) ' transformed orbitals ' END_PROVIDER - - - - - -subroutine trf_to_natorb() - implicit none - BEGIN_DOC - ! save the diagonal somewhere, in inverse order - ! 4-index-transform the 2-particle density matrix over active orbitals - ! correct the bielectronic integrals - ! correct the monoelectronic integrals - ! put integrals on file, as well orbitals, and the density matrices - ! - END_DOC - integer :: i,j,k,l,t,u,p,q,pp - real*8 :: d(n_act_orb),d1(n_act_orb),d2(n_act_orb) - - ! we recalculate total energies - write(6,*) - write(6,*) ' recalculating energies after the transformation ' - write(6,*) - write(6,*) - real*8 :: e_one_all - real*8 :: e_two_all - integer :: ii - integer :: jj - integer :: t3 - integer :: tt - integer :: u3 - integer :: uu - integer :: v - integer :: v3 - integer :: vv - integer :: x - integer :: x3 - integer :: xx - - e_one_all=0.D0 - e_two_all=0.D0 - do i=1,n_core_orb - ii=list_core(i) - e_one_all+=2.D0*one_ints_no(ii,ii) - do j=1,n_core_orb - jj=list_core(j) - e_two_all+=2.D0*bielec_PQxx_no(ii,ii,j,j)-bielec_PQxx_no(ii,jj,j,i) - end do - do t=1,n_act_orb - tt=list_act(t) - t3=t+n_core_orb - e_two_all += occnum(list_act(t)) * & - (2.d0*bielec_PQxx_no(tt,tt,i,i) - bielec_PQxx_no(tt,ii,i,t3)) - end do - end do - - - - do t=1,n_act_orb - tt=list_act(t) - e_one_all += occnum(list_act(t))*one_ints_no(tt,tt) - do u=1,n_act_orb - uu=list_act(u) - do v=1,n_act_orb - v3=v+n_core_orb - do x=1,n_act_orb - x3=x+n_core_orb - e_two_all +=P0tuvx_no(t,u,v,x)*bielec_PQxx_no(tt,uu,v3,x3) - end do - end do - end do - end do - write(6,*) ' e_one_all = ',e_one_all - write(6,*) ' e_two_all = ',e_two_all - ecore =nuclear_repulsion - ecore_bis=nuclear_repulsion - do i=1,n_core_orb - ii=list_core(i) - ecore +=2.D0*one_ints_no(ii,ii) - ecore_bis+=2.D0*one_ints_no(ii,ii) - do j=1,n_core_orb - jj=list_core(j) - ecore +=2.D0*bielec_PQxx_no(ii,ii,j,j)-bielec_PQxx_no(ii,jj,j,i) - ecore_bis+=2.D0*bielec_PxxQ_no(ii,i,j,jj)-bielec_PxxQ_no(ii,j,j,ii) - end do - end do - eone =0.D0 - eone_bis=0.D0 - etwo =0.D0 - etwo_bis=0.D0 - etwo_ter=0.D0 - do t=1,n_act_orb - tt=list_act(t) - t3=t+n_core_orb - eone += occnum(list_act(t))*one_ints_no(tt,tt) - eone_bis += occnum(list_act(t))*one_ints_no(tt,tt) - do i=1,n_core_orb - ii=list_core(i) - eone += occnum(list_act(t)) * & - (2.D0*bielec_PQxx_no(tt,tt,i,i ) - bielec_PQxx_no(tt,ii,i,t3)) - eone_bis += occnum(list_act(t)) * & - (2.D0*bielec_PxxQ_no(tt,t3,i,ii) - bielec_PxxQ_no(tt,i ,i,tt)) - end do - do u=1,n_act_orb - uu=list_act(u) - u3=u+n_core_orb - do v=1,n_act_orb - vv=list_act(v) - v3=v+n_core_orb - do x=1,n_act_orb - xx=list_act(x) - x3=x+n_core_orb - real*8 :: h1,h2,h3 - h1=bielec_PQxx_no(tt,uu,v3,x3) - h2=bielec_PxxQ_no(tt,u3,v3,xx) - h3=bielecCI_no(t,u,v,xx) - etwo +=P0tuvx_no(t,u,v,x)*h1 - etwo_bis+=P0tuvx_no(t,u,v,x)*h2 - etwo_ter+=P0tuvx_no(t,u,v,x)*h3 - if ((abs(h1-h2).gt.1.D-14).or.(abs(h1-h3).gt.1.D-14)) then - write(6,9901) t,u,v,x,h1,h2,h3 - 9901 format('aie: ',4I4,3E20.12) - end if - end do - end do - end do - end do - - write(6,*) ' energy contributions ' - write(6,*) ' core energy = ',ecore,' using PQxx integrals ' - write(6,*) ' core energy (bis) = ',ecore,' using PxxQ integrals ' - write(6,*) ' 1el energy = ',eone ,' using PQxx integrals ' - write(6,*) ' 1el energy (bis) = ',eone ,' using PxxQ integrals ' - write(6,*) ' 2el energy = ',etwo ,' using PQxx integrals ' - write(6,*) ' 2el energy (bis) = ',etwo_bis,' using PxxQ integrals ' - write(6,*) ' 2el energy (ter) = ',etwo_ter,' using tuvP integrals ' - write(6,*) ' ----------------------------------------- ' - write(6,*) ' sum of all = ',eone+etwo+ecore - write(6,*) - SOFT_TOUCH ecore ecore_bis eone eone_bis etwo etwo_bis etwo_ter - -end subroutine trf_to_natorb - diff --git a/src/casscf/neworbs.irp.f b/src/casscf/neworbs.irp.f index fd115880..fd94eb6a 100644 --- a/src/casscf/neworbs.irp.f +++ b/src/casscf/neworbs.irp.f @@ -51,14 +51,16 @@ END_PROVIDER integer :: ierr,matz,i real*8 :: c0 - write(6,*) ' SXdiag : lowest 5 eigenvalues ' - write(6,*) ' 1 - ',SXeigenval(1),SXeigenvec(1,1) - write(6,*) ' 2 - ',SXeigenval(2),SXeigenvec(1,2) - write(6,*) ' 3 - ',SXeigenval(3),SXeigenvec(1,3) - write(6,*) ' 4 - ',SXeigenval(4),SXeigenvec(1,4) - write(6,*) ' 5 - ',SXeigenval(5),SXeigenvec(1,5) - write(6,*) - write(6,*) ' SXdiag : lowest eigenvalue = ',SXeigenval(1) + if (bavard) then + write(6,*) ' SXdiag : lowest 5 eigenvalues ' + write(6,*) ' 1 - ',SXeigenval(1),SXeigenvec(1,1) + write(6,*) ' 2 - ',SXeigenval(2),SXeigenvec(1,2) + write(6,*) ' 3 - ',SXeigenval(3),SXeigenvec(1,3) + write(6,*) ' 4 - ',SXeigenval(4),SXeigenvec(1,4) + write(6,*) ' 5 - ',SXeigenval(5),SXeigenvec(1,5) + write(6,*) + write(6,*) ' SXdiag : lowest eigenvalue = ',SXeigenval(1) + endif energy_improvement = SXeigenval(1) integer :: best_vector @@ -73,16 +75,20 @@ END_PROVIDER end if end do - write(6,*) ' SXdiag : eigenvalue for best overlap with ' - write(6,*) ' previous orbitals = ',SXeigenval(best_vector) energy_improvement = SXeigenval(best_vector) + if (bavard) then + write(6,*) ' SXdiag : eigenvalue for best overlap with ' + write(6,*) ' previous orbitals = ',SXeigenval(best_vector) + write(6,*) ' weight of the 1st element ',c0 + endif + c0=SXeigenvec(1,best_vector) - write(6,*) ' weight of the 1st element ',c0 + do i=1,nMonoEx+1 SXvector(i)=SXeigenvec(i,best_vector)/c0 - ! write(6,*) ' component No ',i,' : ',SXvector(i) end do + END_PROVIDER diff --git a/src/casscf/tot_en.irp.f b/src/casscf/tot_en.irp.f index 780cd543..ce787232 100644 --- a/src/casscf/tot_en.irp.f +++ b/src/casscf/tot_en.irp.f @@ -42,8 +42,6 @@ end do end do end do - write(6,*) ' e_one_all = ',e_one_all - write(6,*) ' e_two_all = ',e_two_all ecore =nuclear_repulsion ecore_bis=nuclear_repulsion do i=1,n_core_orb @@ -98,24 +96,6 @@ end do end do - write(6,*) ' energy contributions ' - write(6,*) ' core energy = ',ecore,' using PQxx integrals ' - write(6,*) ' core energy (bis) = ',ecore,' using PxxQ integrals ' - write(6,*) ' 1el energy = ',eone ,' using PQxx integrals ' - write(6,*) ' 1el energy (bis) = ',eone ,' using PxxQ integrals ' - write(6,*) ' 2el energy = ',etwo ,' using PQxx integrals ' - write(6,*) ' 2el energy (bis) = ',etwo_bis,' using PxxQ integrals ' - write(6,*) ' 2el energy (ter) = ',etwo_ter,' using tuvP integrals ' - write(6,*) ' ----------------------------------------- ' - write(6,*) ' sum of all = ',eone+etwo+ecore - write(6,*) - write(6,*) ' nuclear (qp) = ',nuclear_repulsion - write(6,*) ' core energy (qp) = ',core_energy - write(6,*) ' 1el energy (qp) = ',psi_energy_h_core(1) - write(6,*) ' 2el energy (qp) = ',psi_energy_two_e(1) - write(6,*) ' nuc + 1 + 2 (qp) = ',nuclear_repulsion+psi_energy_h_core(1)+psi_energy_two_e(1) - write(6,*) ' <0|H|0> (qp) = ',psi_energy_with_nucl_rep(1) - END_PROVIDER From 2ef517488c9038b641a4f3c95ca01cb2d38b7181 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 26 Jun 2019 01:43:16 +0200 Subject: [PATCH 11/59] Optimized 1rdm --- src/casscf/bavard.irp.f | 2 +- src/casscf/densities.irp.f | 73 ++++++-------------------------------- src/casscf/det_manip.irp.f | 9 ++--- 3 files changed, 13 insertions(+), 71 deletions(-) diff --git a/src/casscf/bavard.irp.f b/src/casscf/bavard.irp.f index de71a346..a9797712 100644 --- a/src/casscf/bavard.irp.f +++ b/src/casscf/bavard.irp.f @@ -1,6 +1,6 @@ ! -*- F90 -*- BEGIN_PROVIDER [logical, bavard] bavard=.true. - bavard=.false. +! bavard=.false. END_PROVIDER diff --git a/src/casscf/densities.irp.f b/src/casscf/densities.irp.f index 8be2db6e..9b8dba78 100644 --- a/src/casscf/densities.irp.f +++ b/src/casscf/densities.irp.f @@ -1,72 +1,19 @@ use bitmasks BEGIN_PROVIDER [real*8, D0tu, (n_act_orb,n_act_orb) ] - BEGIN_DOC - ! the first-order density matrix in the basis of the starting MOs - ! matrices are state averaged - ! - ! we use the spin-free generators of mono-excitations - ! E_pq destroys q and creates p - ! D_pq = <0|E_pq|0> = D_qp - ! - END_DOC implicit none - integer :: t,u,v,x,mu,nu,istate,ispin,jspin,ihole,ipart,jhole,jpart - integer :: ierr - integer(bit_kind) :: det_mu(N_int,2) - integer(bit_kind) :: det_mu_ex(N_int,2) - integer(bit_kind) :: det_mu_ex1(N_int,2) - integer(bit_kind) :: det_mu_ex2(N_int,2) - real*8 :: phase1,phase2,term - integer :: nu1,nu2 - integer :: ierr1,ierr2 - real*8 :: cI_mu(N_states) + BEGIN_DOC + ! the first-order density matrix in the basis of the starting MOs. + ! matrix is state averaged. + END_DOC + integer :: t,u - if (bavard) then - write(6,*) ' providing density matrix D0' - endif - - D0tu = 0.d0 - - ! first loop: we apply E_tu, once for D_tu, once for -P_tvvu - do mu=1,n_det - call det_extract(det_mu,mu,N_int) - do istate=1,n_states - cI_mu(istate)=psi_coef(mu,istate) - end do + do u=1,n_act_orb do t=1,n_act_orb - ipart=list_act(t) - do u=1,n_act_orb - ihole=list_act(u) - ! apply E_tu - call det_copy(det_mu,det_mu_ex1,N_int) - call det_copy(det_mu,det_mu_ex2,N_int) - call do_spinfree_mono_excitation(det_mu,det_mu_ex1 & - ,det_mu_ex2,nu1,nu2,ihole,ipart,phase1,phase2,ierr1,ierr2) - ! det_mu_ex1 is in the list - if (nu1.ne.-1) then - do istate=1,n_states - term=cI_mu(istate)*psi_coef(nu1,istate)*phase1 - D0tu(t,u)+=term - end do - end if - ! det_mu_ex2 is in the list - if (nu2.ne.-1) then - do istate=1,n_states - term=cI_mu(istate)*psi_coef(nu2,istate)*phase2 - D0tu(t,u)+=term - end do - end if - end do - end do - end do - - ! we average by just dividing by the number of states - do x=1,n_act_orb - do v=1,n_act_orb - D0tu(v,x)*=1.0D0/dble(N_states) - end do - end do + D0tu(t,u) = one_e_dm_mo_alpha_average( list_act(t), list_act(u) ) + & + one_e_dm_mo_beta_average ( list_act(t), list_act(u) ) + enddo + enddo END_PROVIDER diff --git a/src/casscf/det_manip.irp.f b/src/casscf/det_manip.irp.f index adf90196..d8c309a4 100644 --- a/src/casscf/det_manip.irp.f +++ b/src/casscf/det_manip.irp.f @@ -31,6 +31,8 @@ subroutine do_signed_mono_excitation(key1,key2,nu,ihole,ipart, & ! get the number in the list found=.false. nu=0 + + !TODO BOTTLENECK do while (.not.found) nu+=1 if (nu.gt.N_det) then @@ -50,13 +52,6 @@ subroutine do_signed_mono_excitation(key1,key2,nu,ihole,ipart, & end do end if end do - ! if (found) then - ! if (nu.eq.-1) then - ! write(6,*) ' image not found in the list, thus nu = ',nu - ! else - ! write(6,*) ' found in the list as No ',nu,' phase = ',phase - ! end if - ! end if end if ! ! we found the new string, the phase, and possibly the number in the list From 9bb66d5b3a08cef96c9422766e2ebb69ac31a2ac Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Thu, 27 Jun 2019 18:23:28 +0200 Subject: [PATCH 12/59] added the RDMS --- src/casscf/NEED | 1 + src/casscf/test_two_rdm.irp.f | 30 + .../two_e_density_matrix.irp.pouet | 609 ++++++++++++++++++ src/two_body_rdm/NEED | 1 + src/two_body_rdm/README.rst | 6 + src/two_body_rdm/ab_only_routines.irp.f | 402 ++++++++++++ src/two_body_rdm/all_2rdm_routines.irp.f | 443 +++++++++++++ src/two_body_rdm/routines_compute_2rdm.irp.f | 269 ++++++++ src/two_body_rdm/two_rdm.irp.f | 84 +++ 9 files changed, 1845 insertions(+) create mode 100644 src/casscf/test_two_rdm.irp.f create mode 100644 src/determinants/two_e_density_matrix.irp.pouet create mode 100644 src/two_body_rdm/NEED create mode 100644 src/two_body_rdm/README.rst create mode 100644 src/two_body_rdm/ab_only_routines.irp.f create mode 100644 src/two_body_rdm/all_2rdm_routines.irp.f create mode 100644 src/two_body_rdm/routines_compute_2rdm.irp.f create mode 100644 src/two_body_rdm/two_rdm.irp.f diff --git a/src/casscf/NEED b/src/casscf/NEED index d7aff476..c12b531e 100644 --- a/src/casscf/NEED +++ b/src/casscf/NEED @@ -1,3 +1,4 @@ cipsi selectors_full generators_cas +two_body_rdm diff --git a/src/casscf/test_two_rdm.irp.f b/src/casscf/test_two_rdm.irp.f new file mode 100644 index 00000000..562d15a6 --- /dev/null +++ b/src/casscf/test_two_rdm.irp.f @@ -0,0 +1,30 @@ +program print_two_rdm + implicit none + integer :: i,j,k,l + read_wf = .True. + TOUCH read_wf + + double precision, parameter :: thr = 1.d-15 + + double precision :: accu,twodm + accu = 0.d0 + do i=1,mo_num + do j=1,mo_num + do k=1,mo_num + do l=1,mo_num + twodm = coussin_peter_two_rdm_mo(i,j,k,l,1) + if(dabs(twodm - P0tuvx(i,j,k,l)).gt.thr)then + print*,'' + print*,'sum' + write(*,'(3X,4(I2,X),3(F16.13,X))'), i, j, k, l, twodm,P0tuvx(i,j,k,l),dabs(twodm - P0tuvx(i,j,k,l)) + print*,'' + endif + accu += dabs(twodm - P0tuvx(i,j,k,l)) + enddo + enddo + enddo + enddo + print*,'accu = ',accu + print*,' ',accu / dble(mo_num**4) + +end diff --git a/src/determinants/two_e_density_matrix.irp.pouet b/src/determinants/two_e_density_matrix.irp.pouet new file mode 100644 index 00000000..7f8f4896 --- /dev/null +++ b/src/determinants/two_e_density_matrix.irp.pouet @@ -0,0 +1,609 @@ + + BEGIN_PROVIDER [double precision, two_bod_alpha_beta_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] + implicit none + BEGIN_DOC + ! two_bod_alpha_beta(i,j,k,l) = + ! 1 1 2 2 = chemist notations + ! note that no 1/2 factor is introduced in order to take into acccount for the spin symmetry + ! + END_DOC + integer :: dim1,dim2,dim3,dim4 + double precision :: cpu_0,cpu_1 + dim1 = mo_num + dim2 = mo_num + dim3 = mo_num + dim4 = mo_num + two_bod_alpha_beta_mo = 0.d0 + print*,'providing two_bod_alpha_beta ...' + call wall_time(cpu_0) + call two_body_dm_nstates_openmp(two_bod_alpha_beta_mo,dim1,dim2,dim3,dim4,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call wall_time(cpu_1) + print*,'two_bod_alpha_beta provided in',dabs(cpu_1-cpu_0) + + integer :: ii,jj,i,j,k,l + if(no_core_density .EQ. "no_core_dm")then + print*,'USING THE VALENCE ONLY TWO BODY DENSITY' + + do ii = 1, n_core_orb ! 1 + i = list_core(ii) + do j = 1, mo_num ! 2 + do k = 1, mo_num ! 1 + do l = 1, mo_num ! 2 + ! 2 2 1 1 + two_bod_alpha_beta_mo(l,j,k,i,:) = 0.d0 + two_bod_alpha_beta_mo(j,l,k,i,:) = 0.d0 + two_bod_alpha_beta_mo(l,j,i,k,:) = 0.d0 + two_bod_alpha_beta_mo(j,l,i,k,:) = 0.d0 + + two_bod_alpha_beta_mo(k,i,l,j,:) = 0.d0 + two_bod_alpha_beta_mo(k,i,j,l,:) = 0.d0 + two_bod_alpha_beta_mo(i,k,l,j,:) = 0.d0 + two_bod_alpha_beta_mo(i,k,j,l,:) = 0.d0 + enddo + enddo + enddo + enddo + + + endif + + END_PROVIDER + + + BEGIN_PROVIDER [double precision, two_bod_alpha_beta_mo_physicist, (mo_num,mo_num,mo_num,mo_num,N_states)] + implicit none + BEGIN_DOC + ! two_bod_alpha_beta_mo_physicist,(i,j,k,l) = + ! 1 2 1 2 = physicist notations + ! note that no 1/2 factor is introduced in order to take into acccount for the spin symmetry + ! + END_DOC + integer :: i,j,k,l,istate + double precision :: cpu_0,cpu_1 + two_bod_alpha_beta_mo_physicist = 0.d0 + print*,'providing two_bod_alpha_beta_mo_physicist ...' + call wall_time(cpu_0) + do istate = 1, N_states + do i = 1, mo_num + do j = 1, mo_num + do k = 1, mo_num + do l = 1, mo_num + ! 1 2 1 2 1 1 2 2 + two_bod_alpha_beta_mo_physicist(l,k,i,j,istate) = two_bod_alpha_beta_mo(i,l,j,k,istate) + enddo + enddo + enddo + enddo + enddo + call wall_time(cpu_1) + print*,'two_bod_alpha_beta_mo_physicist provided in',dabs(cpu_1-cpu_0) + + END_PROVIDER + + + subroutine two_body_dm_nstates_openmp(big_array,dim1,dim2,dim3,dim4,u_0,N_st,sze) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + ! + ! Assumes that the determinants are in psi_det + ! + ! istart, iend, ishift, istep are used in ZMQ parallelization. + END_DOC + integer, intent(in) :: N_st,sze + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: u_0(sze,N_st) + integer :: k + double precision, allocatable :: u_t(:,:) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t + allocate(u_t(N_st,N_det)) + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det) + enddo + call dtranspose( & + u_0, & + size(u_0, 1), & + u_t, & + size(u_t, 1), & + N_det, N_st) + + call two_body_dm_nstates_openmp_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1) + deallocate(u_t) + + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det) + enddo + + end + + + subroutine two_body_dm_nstates_openmp_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + ! + ! Default should be 1,N_det,0,1 + END_DOC + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + double precision, intent(in) :: u_t(N_st,N_det) + + + PROVIDE N_int + + select case (N_int) + case (1) + call two_body_dm_nstates_openmp_work_1(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (2) + call two_body_dm_nstates_openmp_work_2(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (3) + call two_body_dm_nstates_openmp_work_3(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (4) + call two_body_dm_nstates_openmp_work_4(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case default + call two_body_dm_nstates_openmp_work_N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + end select + end + BEGIN_TEMPLATE + + subroutine two_body_dm_nstates_openmp_work_$N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + double precision, intent(in) :: u_t(N_st,N_det) + + double precision :: hij, sij + integer :: i,j,k,l + integer :: k_a, k_b, l_a, l_b, m_a, m_b + integer :: istate + integer :: krow, kcol, krow_b, kcol_b + integer :: lrow, lcol + integer :: mrow, mcol + integer(bit_kind) :: spindet($N_int) + integer(bit_kind) :: tmp_det($N_int,2) + integer(bit_kind) :: tmp_det2($N_int,2) + integer(bit_kind) :: tmp_det3($N_int,2) + integer(bit_kind), allocatable :: buffer(:,:) + integer :: n_doubles + integer, allocatable :: doubles(:) + integer, allocatable :: singles_a(:) + integer, allocatable :: singles_b(:) + integer, allocatable :: idx(:), idx0(:) + integer :: maxab, n_singles_a, n_singles_b, kcol_prev, nmax + integer*8 :: k8 + + maxab = max(N_det_alpha_unique, N_det_beta_unique)+1 + allocate(idx0(maxab)) + + do i=1,maxab + idx0(i) = i + enddo + + ! Prepare the array of all alpha single excitations + ! ------------------------------------------------- + + PROVIDE N_int nthreads_davidson + + ! Alpha/Beta double excitations + ! ============================= + + allocate( buffer($N_int,maxab), & + singles_a(maxab), & + singles_b(maxab), & + doubles(maxab), & + idx(maxab)) + + kcol_prev=-1 + + ASSERT (iend <= N_det) + ASSERT (istart > 0) + ASSERT (istep > 0) + + do k_a=istart+ishift,iend,istep + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + if (kcol /= kcol_prev) then + call get_all_spin_singles_$N_int( & + psi_det_beta_unique, idx0, & + tmp_det(1,2), N_det_beta_unique, & + singles_b, n_singles_b) + endif + kcol_prev = kcol + + ! Loop over singly excited beta columns + ! ------------------------------------- + + do i=1,n_singles_b + lcol = singles_b(i) + + tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol) + + l_a = psi_bilinear_matrix_columns_loc(lcol) + ASSERT (l_a <= N_det) + + do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow) + + ASSERT (l_a <= N_det) + idx(j) = l_a + l_a = l_a+1 + enddo + j = j-1 + + call get_all_spin_singles_$N_int( & + buffer, idx, tmp_det(1,1), j, & + singles_a, n_singles_a ) + + ! Loop over alpha singles + ! ----------------------- + + do k = 1,n_singles_a + l_a = singles_a(k) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) + !!!!!!!!!!!!!!!!!! ALPHA BETA + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_double_to_two_body_ab_dm(tmp_det,tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + enddo + + enddo + + enddo + + + do k_a=istart+ishift,iend,istep + + + ! Single and double alpha excitations + ! =================================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + ! Initial determinant is at k_b in beta-major representation + ! ---------------------------------------------------------------------- + + k_b = psi_bilinear_matrix_order_transp_reverse(k_a) + + spindet(1:$N_int) = tmp_det(1:$N_int,1) + + ! Loop inside the beta column to gather all the connected alphas + lcol = psi_bilinear_matrix_columns(k_a) + l_a = psi_bilinear_matrix_columns_loc(lcol) + do i=1,N_det_alpha_unique + if (l_a > N_det) exit + lcol = psi_bilinear_matrix_columns(l_a) + if (lcol /= kcol) exit + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow) + idx(i) = l_a + l_a = l_a+1 + enddo + i = i-1 + + call get_all_spin_singles_and_doubles_$N_int( & + buffer, idx, spindet, i, & + singles_a, doubles, n_singles_a, n_doubles ) + + ! Compute Hij for all alpha singles + ! ---------------------------------- + + tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + do i=1,n_singles_a + l_a = singles_a(i) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) + !!!! MONO SPIN + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_single_to_two_body_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + + enddo + + + !! Compute Hij for all alpha doubles + !! ---------------------------------- + ! + !do i=1,n_doubles + ! l_a = doubles(i) + ! ASSERT (l_a <= N_det) + + ! lrow = psi_bilinear_matrix_rows(l_a) + ! ASSERT (lrow <= N_det_alpha_unique) + + ! call i_H_j_double_spin_erf( tmp_det(1,1), psi_det_alpha_unique(1, lrow), $N_int, hij) + ! do l=1,N_st + ! v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) + ! ! same spin => sij = 0 + ! enddo + !enddo + + + + ! Single and double beta excitations + ! ================================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + kcol = psi_bilinear_matrix_columns(k_a) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + spindet(1:$N_int) = tmp_det(1:$N_int,2) + + ! Initial determinant is at k_b in beta-major representation + ! ----------------------------------------------------------------------- + + k_b = psi_bilinear_matrix_order_transp_reverse(k_a) + + ! Loop inside the alpha row to gather all the connected betas + lrow = psi_bilinear_matrix_transp_rows(k_b) + l_b = psi_bilinear_matrix_transp_rows_loc(lrow) + do i=1,N_det_beta_unique + if (l_b > N_det) exit + lrow = psi_bilinear_matrix_transp_rows(l_b) + if (lrow /= krow) exit + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol) + idx(i) = l_b + l_b = l_b+1 + enddo + i = i-1 + + call get_all_spin_singles_and_doubles_$N_int( & + buffer, idx, spindet, i, & + singles_b, doubles, n_singles_b, n_doubles ) + + ! Compute Hij for all beta singles + ! ---------------------------------- + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + do i=1,n_singles_b + l_b = singles_b(i) + ASSERT (l_b <= N_det) + + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol) + l_a = psi_bilinear_matrix_transp_order(l_b) + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_single_to_two_body_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + ASSERT (l_a <= N_det) + enddo + ! + !! Compute Hij for all beta doubles + !! ---------------------------------- + ! + !do i=1,n_doubles + ! l_b = doubles(i) + ! ASSERT (l_b <= N_det) + + ! lcol = psi_bilinear_matrix_transp_columns(l_b) + ! ASSERT (lcol <= N_det_beta_unique) + + ! call i_H_j_double_spin_erf( tmp_det(1,2), psi_det_beta_unique(1, lcol), $N_int, hij) + ! l_a = psi_bilinear_matrix_transp_order(l_b) + ! ASSERT (l_a <= N_det) + + ! do l=1,N_st + ! v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) + ! ! same spin => sij = 0 + ! enddo + !enddo + + + ! Diagonal contribution + ! ===================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + double precision, external :: diag_H_mat_elem_erf, diag_S_mat_elem + double precision :: c_1(N_states),c_2(N_states) + do l = 1, N_states + c_1(l) = u_t(l,k_a) + enddo + + call diagonal_contrib_to_two_body_ab_dm(tmp_det,c_1,big_array,dim1,dim2,dim3,dim4) + + end do + deallocate(buffer, singles_a, singles_b, doubles, idx) + + end + + SUBST [ N_int ] + + 1;; + 2;; + 3;; + 4;; + N_int;; + + END_TEMPLATE + + subroutine diagonal_contrib_to_two_body_ab_dm(det_1,c_1,big_array,dim1,dim2,dim3,dim4) + use bitmasks + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2) + double precision, intent(in) :: c_1(N_states) + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate + double precision :: c_1_bis + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + do istate = 1, N_states + c_1_bis = c_1(istate) * c_1(istate) + do i = 1, n_occ_ab(1) + h1 = occ(i,1) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array(h1,h1,h2,h2,istate) += c_1_bis + enddo + enddo + enddo + end + + subroutine diagonal_contrib_to_all_two_body_dm(det_1,c_1,big_array_ab,big_array_aa,big_array_bb,dim1,dim2,dim3,dim4) + use bitmasks + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2) + double precision, intent(in) :: c_1(N_states) + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate + double precision :: c_1_bis + BEGIN_DOC +! no factor 1/2 have to be taken into account as the permutations are already taken into account + END_DOC + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + do istate = 1, N_states + c_1_bis = c_1(istate) * c_1(istate) + do i = 1, n_occ_ab(1) + h1 = occ(i,1) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array_ab(h1,h1,h2,h2,istate) += c_1_bis + enddo + do j = 1, n_occ_ab(1) + h2 = occ(j,1) + big_array_aa(h1,h2,h1,h2,istate) -= c_1_bis + big_array_aa(h1,h1,h2,h2,istate) += c_1_bis + enddo + enddo + do i = 1, n_occ_ab(2) + h1 = occ(i,2) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array_bb(h1,h1,h2,h2,istate) += c_1_bis + big_array_bb(h1,h2,h1,h2,istate) -= c_1_bis + enddo + enddo + enddo + end + + + subroutine off_diagonal_double_to_two_body_ab_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + use bitmasks + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + double precision, intent(in) :: c_1(N_states),c_2(N_states) + integer :: i,j,h1,h2,p1,p2,istate + integer :: exc(0:2,2,2) + double precision :: phase + call get_double_excitation(det_1,det_2,exc,phase,N_int) + h1 = exc(1,1,1) + h2 = exc(1,1,2) + p1 = exc(1,2,1) + p2 = exc(1,2,2) + do istate = 1, N_states + big_array(h1,p1,h2,p2,istate) += c_1(istate) * phase * c_2(istate) +! big_array(p1,h1,p2,h2,istate) += c_1(istate) * phase * c_2(istate) + enddo + end + + subroutine off_diagonal_single_to_two_body_ab_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + use bitmasks + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + double precision, intent(in) :: c_1(N_states),c_2(N_states) + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate,p1 + integer :: exc(0:2,2,2) + double precision :: phase + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + call get_single_excitation(det_1,det_2,exc,phase,N_int) + if (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + p1 = exc(1,2,1) + do istate = 1, N_states + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + big_array(h1,p1,h2,h2,istate) += 1.d0 * c_1(istate) * c_2(istate) * phase + enddo + enddo + else + ! Mono beta + h1 = exc(1,1,2) + p1 = exc(1,2,2) + do istate = 1, N_states + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + big_array(h2,h2,h1,p1,istate) += 1.d0 * c_1(istate) * c_2(istate) * phase + enddo + enddo + endif + end diff --git a/src/two_body_rdm/NEED b/src/two_body_rdm/NEED new file mode 100644 index 00000000..711fbf96 --- /dev/null +++ b/src/two_body_rdm/NEED @@ -0,0 +1 @@ +davidson_undressed diff --git a/src/two_body_rdm/README.rst b/src/two_body_rdm/README.rst new file mode 100644 index 00000000..1318bb43 --- /dev/null +++ b/src/two_body_rdm/README.rst @@ -0,0 +1,6 @@ +============ +two_body_rdm +============ + +Contains the two rdms (aa,bb,ab) stored as plain arrays + diff --git a/src/two_body_rdm/ab_only_routines.irp.f b/src/two_body_rdm/ab_only_routines.irp.f new file mode 100644 index 00000000..195f439a --- /dev/null +++ b/src/two_body_rdm/ab_only_routines.irp.f @@ -0,0 +1,402 @@ + + subroutine two_rdm_dm_nstates_openmp(big_array,dim1,dim2,dim3,dim4,u_0,N_st,sze) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + ! + ! Assumes that the determinants are in psi_det + ! + ! istart, iend, ishift, istep are used in ZMQ parallelization. + END_DOC + integer, intent(in) :: N_st,sze + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: u_0(sze,N_st) + integer :: k + double precision, allocatable :: u_t(:,:) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t + allocate(u_t(N_st,N_det)) + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det) + enddo + call dtranspose( & + u_0, & + size(u_0, 1), & + u_t, & + size(u_t, 1), & + N_det, N_st) + + call two_rdm_dm_nstates_openmp_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1) + deallocate(u_t) + + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det) + enddo + + end + + + subroutine two_rdm_dm_nstates_openmp_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + ! + ! Default should be 1,N_det,0,1 + END_DOC + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + double precision, intent(in) :: u_t(N_st,N_det) + + + PROVIDE N_int + + select case (N_int) + case (1) + call two_rdm_dm_nstates_openmp_work_1(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (2) + call two_rdm_dm_nstates_openmp_work_2(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (3) + call two_rdm_dm_nstates_openmp_work_3(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (4) + call two_rdm_dm_nstates_openmp_work_4(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case default + call two_rdm_dm_nstates_openmp_work_N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + end select + end + BEGIN_TEMPLATE + + subroutine two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + double precision, intent(in) :: u_t(N_st,N_det) + + double precision :: hij, sij + integer :: i,j,k,l + integer :: k_a, k_b, l_a, l_b, m_a, m_b + integer :: istate + integer :: krow, kcol, krow_b, kcol_b + integer :: lrow, lcol + integer :: mrow, mcol + integer(bit_kind) :: spindet($N_int) + integer(bit_kind) :: tmp_det($N_int,2) + integer(bit_kind) :: tmp_det2($N_int,2) + integer(bit_kind) :: tmp_det3($N_int,2) + integer(bit_kind), allocatable :: buffer(:,:) + integer :: n_doubles + integer, allocatable :: doubles(:) + integer, allocatable :: singles_a(:) + integer, allocatable :: singles_b(:) + integer, allocatable :: idx(:), idx0(:) + integer :: maxab, n_singles_a, n_singles_b, kcol_prev, nmax + integer*8 :: k8 + + maxab = max(N_det_alpha_unique, N_det_beta_unique)+1 + allocate(idx0(maxab)) + + do i=1,maxab + idx0(i) = i + enddo + + ! Prepare the array of all alpha single excitations + ! ------------------------------------------------- + + PROVIDE N_int nthreads_davidson + + ! Alpha/Beta double excitations + ! ============================= + + allocate( buffer($N_int,maxab), & + singles_a(maxab), & + singles_b(maxab), & + doubles(maxab), & + idx(maxab)) + + kcol_prev=-1 + + ASSERT (iend <= N_det) + ASSERT (istart > 0) + ASSERT (istep > 0) + + do k_a=istart+ishift,iend,istep + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + if (kcol /= kcol_prev) then + call get_all_spin_singles_$N_int( & + psi_det_beta_unique, idx0, & + tmp_det(1,2), N_det_beta_unique, & + singles_b, n_singles_b) + endif + kcol_prev = kcol + + ! Loop over singly excited beta columns + ! ------------------------------------- + + do i=1,n_singles_b + lcol = singles_b(i) + + tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol) + + l_a = psi_bilinear_matrix_columns_loc(lcol) + ASSERT (l_a <= N_det) + + do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow) + + ASSERT (l_a <= N_det) + idx(j) = l_a + l_a = l_a+1 + enddo + j = j-1 + + call get_all_spin_singles_$N_int( & + buffer, idx, tmp_det(1,1), j, & + singles_a, n_singles_a ) + + ! Loop over alpha singles + ! ----------------------- + + do k = 1,n_singles_a + l_a = singles_a(k) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) + !!!!!!!!!!!!!!!!!! ALPHA BETA + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_double_to_two_rdm_ab_dm(tmp_det,tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + enddo + + enddo + + enddo + + + do k_a=istart+ishift,iend,istep + + + ! Single and double alpha excitations + ! =================================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + ! Initial determinant is at k_b in beta-major representation + ! ---------------------------------------------------------------------- + + k_b = psi_bilinear_matrix_order_transp_reverse(k_a) + + spindet(1:$N_int) = tmp_det(1:$N_int,1) + + ! Loop inside the beta column to gather all the connected alphas + lcol = psi_bilinear_matrix_columns(k_a) + l_a = psi_bilinear_matrix_columns_loc(lcol) + do i=1,N_det_alpha_unique + if (l_a > N_det) exit + lcol = psi_bilinear_matrix_columns(l_a) + if (lcol /= kcol) exit + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow) + idx(i) = l_a + l_a = l_a+1 + enddo + i = i-1 + + call get_all_spin_singles_and_doubles_$N_int( & + buffer, idx, spindet, i, & + singles_a, doubles, n_singles_a, n_doubles ) + + ! Compute Hij for all alpha singles + ! ---------------------------------- + + tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + do i=1,n_singles_a + l_a = singles_a(i) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) + !!!! MONO SPIN + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + + enddo + + + !! Compute Hij for all alpha doubles + !! ---------------------------------- + ! + !do i=1,n_doubles + ! l_a = doubles(i) + ! ASSERT (l_a <= N_det) + + ! lrow = psi_bilinear_matrix_rows(l_a) + ! ASSERT (lrow <= N_det_alpha_unique) + + ! call i_H_j_double_spin_erf( tmp_det(1,1), psi_det_alpha_unique(1, lrow), $N_int, hij) + ! do l=1,N_st + ! v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) + ! ! same spin => sij = 0 + ! enddo + !enddo + + + + ! Single and double beta excitations + ! ================================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + kcol = psi_bilinear_matrix_columns(k_a) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + spindet(1:$N_int) = tmp_det(1:$N_int,2) + + ! Initial determinant is at k_b in beta-major representation + ! ----------------------------------------------------------------------- + + k_b = psi_bilinear_matrix_order_transp_reverse(k_a) + + ! Loop inside the alpha row to gather all the connected betas + lrow = psi_bilinear_matrix_transp_rows(k_b) + l_b = psi_bilinear_matrix_transp_rows_loc(lrow) + do i=1,N_det_beta_unique + if (l_b > N_det) exit + lrow = psi_bilinear_matrix_transp_rows(l_b) + if (lrow /= krow) exit + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol) + idx(i) = l_b + l_b = l_b+1 + enddo + i = i-1 + + call get_all_spin_singles_and_doubles_$N_int( & + buffer, idx, spindet, i, & + singles_b, doubles, n_singles_b, n_doubles ) + + ! Compute Hij for all beta singles + ! ---------------------------------- + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + do i=1,n_singles_b + l_b = singles_b(i) + ASSERT (l_b <= N_det) + + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol) + l_a = psi_bilinear_matrix_transp_order(l_b) + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + ASSERT (l_a <= N_det) + enddo + ! + !! Compute Hij for all beta doubles + !! ---------------------------------- + ! + !do i=1,n_doubles + ! l_b = doubles(i) + ! ASSERT (l_b <= N_det) + + ! lcol = psi_bilinear_matrix_transp_columns(l_b) + ! ASSERT (lcol <= N_det_beta_unique) + + ! call i_H_j_double_spin_erf( tmp_det(1,2), psi_det_beta_unique(1, lcol), $N_int, hij) + ! l_a = psi_bilinear_matrix_transp_order(l_b) + ! ASSERT (l_a <= N_det) + + ! do l=1,N_st + ! v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,l_a) + ! ! same spin => sij = 0 + ! enddo + !enddo + + + ! Diagonal contribution + ! ===================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + double precision, external :: diag_H_mat_elem_erf, diag_S_mat_elem + double precision :: c_1(N_states),c_2(N_states) + do l = 1, N_states + c_1(l) = u_t(l,k_a) + enddo + + call diagonal_contrib_to_two_rdm_ab_dm(tmp_det,c_1,big_array,dim1,dim2,dim3,dim4) + + end do + deallocate(buffer, singles_a, singles_b, doubles, idx) + + end + + SUBST [ N_int ] + + 1;; + 2;; + 3;; + 4;; + N_int;; + + END_TEMPLATE diff --git a/src/two_body_rdm/all_2rdm_routines.irp.f b/src/two_body_rdm/all_2rdm_routines.irp.f new file mode 100644 index 00000000..6536e382 --- /dev/null +++ b/src/two_body_rdm/all_2rdm_routines.irp.f @@ -0,0 +1,443 @@ + + subroutine all_two_rdm_dm_nstates_openmp(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_0,N_st,sze) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + ! + ! Assumes that the determinants are in psi_det + ! + ! istart, iend, ishift, istep are used in ZMQ parallelization. + END_DOC + integer, intent(in) :: N_st,sze + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: u_0(sze,N_st) + integer :: k + double precision, allocatable :: u_t(:,:) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t + allocate(u_t(N_st,N_det)) + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det) + enddo + call dtranspose( & + u_0, & + size(u_0, 1), & + u_t, & + size(u_t, 1), & + N_det, N_st) + + call all_two_rdm_dm_nstates_openmp_work(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1) + deallocate(u_t) + + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det) + enddo + + end + + + subroutine all_two_rdm_dm_nstates_openmp_work(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + BEGIN_DOC + ! Computes two-rdm + ! + ! Default should be 1,N_det,0,1 + END_DOC + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states) + double precision, intent(in) :: u_t(N_st,N_det) + + + PROVIDE N_int + + select case (N_int) + case (1) + call all_two_rdm_dm_nstates_openmp_work_1(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (2) + call all_two_rdm_dm_nstates_openmp_work_2(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (3) + call all_two_rdm_dm_nstates_openmp_work_3(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (4) + call all_two_rdm_dm_nstates_openmp_work_4(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case default + call all_two_rdm_dm_nstates_openmp_work_N_int(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + end select + end + +BEGIN_TEMPLATE + +subroutine all_two_rdm_dm_nstates_openmp_work_$N_int(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + BEGIN_DOC + ! Computes $v_t = H | u_t \\rangle$ and $s_t = S^2 | u_t \\rangle$ + ! + ! Default should be 1,N_det,0,1 + END_DOC + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + double precision, intent(in) :: u_t(N_st,N_det) + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states) + + integer :: i,j,k,l + integer :: k_a, k_b, l_a, l_b, m_a, m_b + integer :: istate + integer :: krow, kcol, krow_b, kcol_b + integer :: lrow, lcol + integer :: mrow, mcol + integer(bit_kind) :: spindet($N_int) + integer(bit_kind) :: tmp_det($N_int,2) + integer(bit_kind) :: tmp_det2($N_int,2) + integer(bit_kind) :: tmp_det3($N_int,2) + integer(bit_kind), allocatable :: buffer(:,:) + integer :: n_doubles + integer, allocatable :: doubles(:) + integer, allocatable :: singles_a(:) + integer, allocatable :: singles_b(:) + integer, allocatable :: idx(:), idx0(:) + integer :: maxab, n_singles_a, n_singles_b, kcol_prev + integer*8 :: k8 + + maxab = max(N_det_alpha_unique, N_det_beta_unique)+1 + allocate(idx0(maxab)) + + do i=1,maxab + idx0(i) = i + enddo + + ! Prepare the array of all alpha single excitations + ! ------------------------------------------------- + + PROVIDE N_int nthreads_davidson + !!$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) & + ! !$OMP SHARED(psi_bilinear_matrix_rows, N_det, & + ! !$OMP psi_bilinear_matrix_columns, & + ! !$OMP psi_det_alpha_unique, psi_det_beta_unique, & + ! !$OMP n_det_alpha_unique, n_det_beta_unique, N_int, & + ! !$OMP psi_bilinear_matrix_transp_rows, & + ! !$OMP psi_bilinear_matrix_transp_columns, & + ! !$OMP psi_bilinear_matrix_transp_order, N_st, & + ! !$OMP psi_bilinear_matrix_order_transp_reverse, & + ! !$OMP psi_bilinear_matrix_columns_loc, & + ! !$OMP psi_bilinear_matrix_transp_rows_loc, & + ! !$OMP istart, iend, istep, irp_here, v_t, s_t, & + ! !$OMP ishift, idx0, u_t, maxab) & + ! !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i, & + ! !$OMP lcol, lrow, l_a, l_b, & + ! !$OMP buffer, doubles, n_doubles, & + ! !$OMP tmp_det2, idx, l, kcol_prev, & + ! !$OMP singles_a, n_singles_a, singles_b, & + ! !$OMP n_singles_b, k8) + + ! Alpha/Beta double excitations + ! ============================= + + allocate( buffer($N_int,maxab), & + singles_a(maxab), & + singles_b(maxab), & + doubles(maxab), & + idx(maxab)) + + kcol_prev=-1 + + ASSERT (iend <= N_det) + ASSERT (istart > 0) + ASSERT (istep > 0) + + !!$OMP DO SCHEDULE(dynamic,64) + do k_a=istart+ishift,iend,istep + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + if (kcol /= kcol_prev) then + call get_all_spin_singles_$N_int( & + psi_det_beta_unique, idx0, & + tmp_det(1,2), N_det_beta_unique, & + singles_b, n_singles_b) + endif + kcol_prev = kcol + + ! Loop over singly excited beta columns + ! ------------------------------------- + + do i=1,n_singles_b + lcol = singles_b(i) + + tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol) + + l_a = psi_bilinear_matrix_columns_loc(lcol) + ASSERT (l_a <= N_det) + + do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow) + + ASSERT (l_a <= N_det) + idx(j) = l_a + l_a = l_a+1 + enddo + j = j-1 + + call get_all_spin_singles_$N_int( & + buffer, idx, tmp_det(1,1), j, & + singles_a, n_singles_a ) + + ! Loop over alpha singles + ! ----------------------- + + do k = 1,n_singles_a + l_a = singles_a(k) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) + !call i_H_j_double_alpha_beta(tmp_det,tmp_det2,$N_int,hij) + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_double_to_two_rdm_ab_dm(tmp_det,tmp_det2,c_1,c_2,big_array_ab,dim1,dim2,dim3,dim4) + enddo + + enddo + + enddo +! !$OMP END DO + +! !$OMP DO SCHEDULE(dynamic,64) + do k_a=istart+ishift,iend,istep + + + ! Single and double alpha exitations + ! =================================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + ! Initial determinant is at k_b in beta-major representation + ! ---------------------------------------------------------------------- + + k_b = psi_bilinear_matrix_order_transp_reverse(k_a) + ASSERT (k_b <= N_det) + + spindet(1:$N_int) = tmp_det(1:$N_int,1) + + ! Loop inside the beta column to gather all the connected alphas + lcol = psi_bilinear_matrix_columns(k_a) + l_a = psi_bilinear_matrix_columns_loc(lcol) + do i=1,N_det_alpha_unique + if (l_a > N_det) exit + lcol = psi_bilinear_matrix_columns(l_a) + if (lcol /= kcol) exit + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow) + idx(i) = l_a + l_a = l_a+1 + enddo + i = i-1 + + call get_all_spin_singles_and_doubles_$N_int( & + buffer, idx, spindet, i, & + singles_a, doubles, n_singles_a, n_doubles ) + + ! Compute Hij for all alpha singles + ! ---------------------------------- + + tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + do i=1,n_singles_a + l_a = singles_a(i) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + ! increment the alpha/beta part for single excitations + call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array_ab,dim1,dim2,dim3,dim4) + ! increment the alpha/alpha part for single excitations + call off_diagonal_single_to_two_rdm_aa_dm(tmp_det,tmp_det2,c_1,c_2,big_array_aa,dim1,dim2,dim3,dim4) + + enddo + + + ! Compute Hij for all alpha doubles + ! ---------------------------------- + + do i=1,n_doubles + l_a = doubles(i) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_double_to_two_rdm_aa_dm(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_1,c_2,big_array_aa,dim1,dim2,dim3,dim4) + enddo + + + ! Single and double beta excitations + ! ================================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + kcol = psi_bilinear_matrix_columns(k_a) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + spindet(1:$N_int) = tmp_det(1:$N_int,2) + + ! Initial determinant is at k_b in beta-major representation + ! ----------------------------------------------------------------------- + + k_b = psi_bilinear_matrix_order_transp_reverse(k_a) + ASSERT (k_b <= N_det) + + ! Loop inside the alpha row to gather all the connected betas + lrow = psi_bilinear_matrix_transp_rows(k_b) + l_b = psi_bilinear_matrix_transp_rows_loc(lrow) + do i=1,N_det_beta_unique + if (l_b > N_det) exit + lrow = psi_bilinear_matrix_transp_rows(l_b) + if (lrow /= krow) exit + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol) + idx(i) = l_b + l_b = l_b+1 + enddo + i = i-1 + + call get_all_spin_singles_and_doubles_$N_int( & + buffer, idx, spindet, i, & + singles_b, doubles, n_singles_b, n_doubles ) + + ! Compute Hij for all beta singles + ! ---------------------------------- + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + do i=1,n_singles_b + l_b = singles_b(i) + ASSERT (l_b <= N_det) + + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol) + l_a = psi_bilinear_matrix_transp_order(l_b) + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + ! increment the alpha/beta part for single excitations + call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array_ab,dim1,dim2,dim3,dim4) + ! increment the beta /beta part for single excitations + call off_diagonal_single_to_two_rdm_bb_dm(tmp_det, tmp_det2,c_1,c_2,big_array_bb,dim1,dim2,dim3,dim4) + enddo + + ! Compute Hij for all beta doubles + ! ---------------------------------- + + do i=1,n_doubles + l_b = doubles(i) + ASSERT (l_b <= N_det) + + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + l_a = psi_bilinear_matrix_transp_order(l_b) + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_alpha_unique(1, lcol),c_1,c_2,big_array_bb,dim1,dim2,dim3,dim4) + ASSERT (l_a <= N_det) + + enddo + + + ! Diagonal contribution + ! ===================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + double precision, external :: diag_wee_mat_elem, diag_S_mat_elem + + double precision :: c_1(N_states),c_2(N_states) + do l = 1, N_states + c_1(l) = u_t(l,k_a) + enddo + + call diagonal_contrib_to_all_two_rdm_dm(tmp_det,c_1,big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4) + + end do + !!$OMP END DO + deallocate(buffer, singles_a, singles_b, doubles, idx) + !!$OMP END PARALLEL + +end + +SUBST [ N_int ] + +1;; +2;; +3;; +4;; +N_int;; + +END_TEMPLATE + diff --git a/src/two_body_rdm/routines_compute_2rdm.irp.f b/src/two_body_rdm/routines_compute_2rdm.irp.f new file mode 100644 index 00000000..7165576f --- /dev/null +++ b/src/two_body_rdm/routines_compute_2rdm.irp.f @@ -0,0 +1,269 @@ + + + subroutine diagonal_contrib_to_two_rdm_ab_dm(det_1,c_1,big_array,dim1,dim2,dim3,dim4) + use bitmasks + BEGIN_DOC +! routine that update the DIAGONAL PART of the alpha/beta two body rdm + END_DOC + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2) + double precision, intent(in) :: c_1(N_states) + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate + double precision :: c_1_bis + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + do istate = 1, N_states + c_1_bis = c_1(istate) * c_1(istate) + do i = 1, n_occ_ab(1) + h1 = occ(i,1) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array(h1,h1,h2,h2,istate) += c_1_bis + enddo + enddo + enddo + end + + + subroutine diagonal_contrib_to_all_two_rdm_dm(det_1,c_1,big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4) + use bitmasks + BEGIN_DOC +! routine that update the DIAGONAL PART of ALL THREE two body rdm + END_DOC + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2) + double precision, intent(in) :: c_1(N_states) + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate + double precision :: c_1_bis + BEGIN_DOC +! no factor 1/2 have to be taken into account as the permutations are already taken into account + END_DOC + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + do istate = 1, N_states + c_1_bis = c_1(istate) * c_1(istate) + do i = 1, n_occ_ab(1) + h1 = occ(i,1) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array_ab(h1,h1,h2,h2,istate) += c_1_bis + enddo + do j = 1, n_occ_ab(1) + h2 = occ(j,1) + big_array_aa(h1,h1,h2,h2,istate) += 0.5d0 * c_1_bis + big_array_aa(h1,h2,h2,h1,istate) -= 0.5d0 * c_1_bis + enddo + enddo + do i = 1, n_occ_ab(2) + h1 = occ(i,2) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array_bb(h1,h1,h2,h2,istate) += 0.5d0 * c_1_bis + big_array_bb(h1,h2,h2,h1,istate) -= 0.5d0 * c_1_bis + enddo + enddo + enddo + end + + + subroutine off_diagonal_double_to_two_rdm_ab_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the alpha/beta 2RDM only for DOUBLE EXCITATIONS + END_DOC + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + double precision, intent(in) :: c_1(N_states),c_2(N_states) + integer :: i,j,h1,h2,p1,p2,istate + integer :: exc(0:2,2,2) + double precision :: phase + call get_double_excitation(det_1,det_2,exc,phase,N_int) + h1 = exc(1,1,1) + h2 = exc(1,1,2) + p1 = exc(1,2,1) + p2 = exc(1,2,2) + do istate = 1, N_states + big_array(h1,p1,h2,p2,istate) += c_1(istate) * phase * c_2(istate) +! big_array(p1,h1,p2,h2,istate) += c_1(istate) * phase * c_2(istate) + enddo + end + + subroutine off_diagonal_single_to_two_rdm_ab_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the alpha/beta 2RDM only for SINGLE EXCITATIONS + END_DOC + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + double precision, intent(in) :: c_1(N_states),c_2(N_states) + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate,p1 + integer :: exc(0:2,2,2) + double precision :: phase + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + call get_single_excitation(det_1,det_2,exc,phase,N_int) + if (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + p1 = exc(1,2,1) + do istate = 1, N_states + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + big_array(h1,p1,h2,h2,istate) += 1.d0 * c_1(istate) * c_2(istate) * phase + enddo + enddo + else + ! Mono beta + h1 = exc(1,1,2) + p1 = exc(1,2,2) + do istate = 1, N_states + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + big_array(h2,h2,h1,p1,istate) += 1.d0 * c_1(istate) * c_2(istate) * phase + enddo + enddo + endif + end + + subroutine off_diagonal_single_to_two_rdm_aa_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the alpha/alpha 2RDM only for SINGLE EXCITATIONS + END_DOC + use bitmasks + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + double precision, intent(in) :: c_1(N_states),c_2(N_states) + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate,p1 + integer :: exc(0:2,2,2) + double precision :: phase + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + call get_single_excitation(det_1,det_2,exc,phase,N_int) + if (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + p1 = exc(1,2,1) + do istate = 1, N_states + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + big_array(h1,p1,h2,h2,istate) += 0.5d0 * c_1(istate) * c_2(istate) * phase + big_array(h1,h2,h2,p1,istate) -= 0.5d0 * c_1(istate) * c_2(istate) * phase + + big_array(h2,h2,h1,p1,istate) += 0.5d0 * c_1(istate) * c_2(istate) * phase + big_array(h2,p1,h1,h2,istate) -= 0.5d0 * c_1(istate) * c_2(istate) * phase + enddo + enddo + else + return + endif + end + + subroutine off_diagonal_single_to_two_rdm_bb_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the beta /beta 2RDM only for SINGLE EXCITATIONS + END_DOC + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + double precision, intent(in) :: c_1(N_states),c_2(N_states) + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate,p1 + integer :: exc(0:2,2,2) + double precision :: phase + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + call get_single_excitation(det_1,det_2,exc,phase,N_int) + if (exc(0,1,1) == 1) then + return + else + ! Mono beta + h1 = exc(1,1,2) + p1 = exc(1,2,2) + do istate = 1, N_states + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + big_array(h1,p1,h2,h2,istate) += 0.5d0 * c_1(istate) * c_2(istate) * phase + big_array(h1,h2,h2,p1,istate) -= 0.5d0 * c_1(istate) * c_2(istate) * phase + + big_array(h2,h2,h1,p1,istate) += 0.5d0 * c_1(istate) * c_2(istate) * phase + big_array(h2,p1,h1,h2,istate) -= 0.5d0 * c_1(istate) * c_2(istate) * phase + enddo + enddo + endif + end + + + subroutine off_diagonal_double_to_two_rdm_aa_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the alpha/alpha 2RDM only for DOUBLE EXCITATIONS + END_DOC + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) + double precision, intent(in) :: c_1(N_states),c_2(N_states) + integer :: i,j,h1,h2,p1,p2,istate + integer :: exc(0:2,2) + double precision :: phase + call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) + h1 =exc(1,1) + h2 =exc(2,1) + p1 =exc(1,2) + p2 =exc(2,2) +!print*,'h1,p1,h2,p2',h1,p1,h2,p2,c_1(istate) * phase * c_2(istate) + do istate = 1, N_states + big_array(h1,p1,h2,p2,istate) += 0.5d0 * c_1(istate) * phase * c_2(istate) + big_array(h1,p2,h2,p1,istate) -= 0.5d0 * c_1(istate) * phase * c_2(istate) + + big_array(h2,p2,h1,p1,istate) += 0.5d0 * c_1(istate) * phase * c_2(istate) + big_array(h2,p1,h1,p2,istate) -= 0.5d0 * c_1(istate) * phase * c_2(istate) + enddo + end + + subroutine off_diagonal_double_to_two_rdm_bb_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the beta /beta 2RDM only for DOUBLE EXCITATIONS + END_DOC + implicit none + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array(dim1,dim2,dim3,dim4,N_states) + integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) + double precision, intent(in) :: c_1(N_states),c_2(N_states) + integer :: i,j,h1,h2,p1,p2,istate + integer :: exc(0:2,2) + double precision :: phase + call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) + h1 =exc(1,1) + h2 =exc(2,1) + p1 =exc(1,2) + p2 =exc(2,2) +!print*,'h1,p1,h2,p2',h1,p1,h2,p2,c_1(istate) * phase * c_2(istate) + do istate = 1, N_states + big_array(h1,p1,h2,p2,istate) += 0.5d0 * c_1(istate) * phase * c_2(istate) + big_array(h1,p2,h2,p1,istate) -= 0.5d0 * c_1(istate) * phase * c_2(istate) + + big_array(h2,p2,h1,p1,istate) += 0.5d0 * c_1(istate) * phase * c_2(istate) + big_array(h2,p1,h1,p2,istate) -= 0.5d0 * c_1(istate) * phase * c_2(istate) + enddo + end + diff --git a/src/two_body_rdm/two_rdm.irp.f b/src/two_body_rdm/two_rdm.irp.f new file mode 100644 index 00000000..1c299bba --- /dev/null +++ b/src/two_body_rdm/two_rdm.irp.f @@ -0,0 +1,84 @@ + + BEGIN_PROVIDER [double precision, coussin_peter_two_rdm_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] + implicit none + BEGIN_DOC + ! coussin_peter_two_rdm_mo(i,j,k,l) = the two rdm that peter wants for his CASSCF + END_DOC + integer :: i,j,k,l + do l = 1, mo_num + do k = 1, mo_num + do j = 1, mo_num + do i = 1, mo_num + coussin_peter_two_rdm_mo(i,j,k,l,:) = 0.5d0 * (two_rdm_alpha_beta_mo(i,j,k,l,:) + two_rdm_alpha_beta_mo(i,j,k,l,:)) & + + two_rdm_alpha_alpha_mo(i,j,k,l,:) & + + two_rdm_beta_beta_mo(i,j,k,l,:) + enddo + enddo + enddo + enddo + + END_PROVIDER + + + BEGIN_PROVIDER [double precision, two_rdm_alpha_beta_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] +&BEGIN_PROVIDER [double precision, two_rdm_alpha_alpha_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] +&BEGIN_PROVIDER [double precision, two_rdm_beta_beta_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] + implicit none + BEGIN_DOC + ! two_rdm_alpha_beta(i,j,k,l) = + ! 1 1 2 2 = chemist notations + ! note that no 1/2 factor is introduced in order to take into acccount for the spin symmetry + ! + END_DOC + integer :: dim1,dim2,dim3,dim4 + double precision :: cpu_0,cpu_1 + dim1 = mo_num + dim2 = mo_num + dim3 = mo_num + dim4 = mo_num + two_rdm_alpha_beta_mo = 0.d0 + two_rdm_alpha_alpha_mo= 0.d0 + two_rdm_beta_beta_mo = 0.d0 + print*,'providing two_rdm_alpha_beta ...' + call wall_time(cpu_0) + call all_two_rdm_dm_nstates_openmp(two_rdm_alpha_alpha_mo,two_rdm_beta_beta_mo,two_rdm_alpha_beta_mo,dim1,dim2,dim3,dim4,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call wall_time(cpu_1) + print*,'two_rdm_alpha_beta provided in',dabs(cpu_1-cpu_0) + + END_PROVIDER + + + BEGIN_PROVIDER [double precision, two_rdm_alpha_beta_mo_physicist, (mo_num,mo_num,mo_num,mo_num,N_states)] +&BEGIN_PROVIDER [double precision, two_rdm_alpha_alpha_mo_physicist, (mo_num,mo_num,mo_num,mo_num,N_states)] +&BEGIN_PROVIDER [double precision, two_rdm_beta_beta_mo_physicist, (mo_num,mo_num,mo_num,mo_num,N_states)] + implicit none + BEGIN_DOC + ! two_rdm_alpha_beta_mo_physicist,(i,j,k,l) = + ! 1 2 1 2 = physicist notations + ! note that no 1/2 factor is introduced in order to take into acccount for the spin symmetry + ! + END_DOC + integer :: i,j,k,l,istate + double precision :: cpu_0,cpu_1 + two_rdm_alpha_beta_mo_physicist = 0.d0 + print*,'providing two_rdm_alpha_beta_mo_physicist ...' + call wall_time(cpu_0) + do istate = 1, N_states + do i = 1, mo_num + do j = 1, mo_num + do k = 1, mo_num + do l = 1, mo_num + ! 1 2 1 2 1 1 2 2 + two_rdm_alpha_beta_mo_physicist(l,k,i,j,istate) = two_rdm_alpha_beta_mo(i,l,j,k,istate) + two_rdm_alpha_alpha_mo_physicist(l,k,i,j,istate) = two_rdm_alpha_alpha_mo(i,l,j,k,istate) + two_rdm_beta_beta_mo_physicist(l,k,i,j,istate) = two_rdm_beta_beta_mo(i,l,j,k,istate) + enddo + enddo + enddo + enddo + enddo + call wall_time(cpu_1) + print*,'two_rdm_alpha_beta_mo_physicist provided in',dabs(cpu_1-cpu_0) + + END_PROVIDER + From 3e38912dcb484c2e396e182c47080ce561748445 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 27 Jun 2019 21:41:17 +0200 Subject: [PATCH 13/59] indentation --- src/casscf/test_two_rdm.irp.f | 10 +- src/two_body_rdm/README.rst | 4 +- src/two_body_rdm/all_2rdm_routines.irp.f | 877 +++++++++++------------ src/two_body_rdm/two_rdm.irp.f | 138 ++-- 4 files changed, 516 insertions(+), 513 deletions(-) diff --git a/src/casscf/test_two_rdm.irp.f b/src/casscf/test_two_rdm.irp.f index 562d15a6..f2afdb25 100644 --- a/src/casscf/test_two_rdm.irp.f +++ b/src/casscf/test_two_rdm.irp.f @@ -8,11 +8,11 @@ program print_two_rdm double precision :: accu,twodm accu = 0.d0 - do i=1,mo_num - do j=1,mo_num - do k=1,mo_num - do l=1,mo_num - twodm = coussin_peter_two_rdm_mo(i,j,k,l,1) + do i=1,n_act_orb + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,n_act_orb + twodm = coussin_peter_two_rdm_mo(list_act(i),list_act(j),list_act(k),list_act(l),1) if(dabs(twodm - P0tuvx(i,j,k,l)).gt.thr)then print*,'' print*,'sum' diff --git a/src/two_body_rdm/README.rst b/src/two_body_rdm/README.rst index 1318bb43..ea5839e8 100644 --- a/src/two_body_rdm/README.rst +++ b/src/two_body_rdm/README.rst @@ -2,5 +2,7 @@ two_body_rdm ============ -Contains the two rdms (aa,bb,ab) stored as plain arrays +Contains the two rdms $\alpha\alpha$, $\beta\beta$ and $\alpha\beta$ stored as +maps, with pysicists notation, consistent with the two-electron integrals in the +MO basis. diff --git a/src/two_body_rdm/all_2rdm_routines.irp.f b/src/two_body_rdm/all_2rdm_routines.irp.f index 6536e382..75d71ded 100644 --- a/src/two_body_rdm/all_2rdm_routines.irp.f +++ b/src/two_body_rdm/all_2rdm_routines.irp.f @@ -1,443 +1,442 @@ - - subroutine all_two_rdm_dm_nstates_openmp(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_0,N_st,sze) - use bitmasks - implicit none - BEGIN_DOC - ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> - ! - ! Assumes that the determinants are in psi_det - ! - ! istart, iend, ishift, istep are used in ZMQ parallelization. - END_DOC - integer, intent(in) :: N_st,sze - integer, intent(in) :: dim1,dim2,dim3,dim4 - double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states) - double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states) - double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states) - double precision, intent(inout) :: u_0(sze,N_st) - integer :: k - double precision, allocatable :: u_t(:,:) - !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t - allocate(u_t(N_st,N_det)) - do k=1,N_st - call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det) - enddo - call dtranspose( & - u_0, & - size(u_0, 1), & - u_t, & - size(u_t, 1), & - N_det, N_st) - - call all_two_rdm_dm_nstates_openmp_work(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1) - deallocate(u_t) - - do k=1,N_st - call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det) - enddo - - end - - - subroutine all_two_rdm_dm_nstates_openmp_work(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) - use bitmasks - implicit none - BEGIN_DOC - ! Computes two-rdm - ! - ! Default should be 1,N_det,0,1 - END_DOC - integer, intent(in) :: N_st,sze,istart,iend,ishift,istep - integer, intent(in) :: dim1,dim2,dim3,dim4 - double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states) - double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states) - double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states) - double precision, intent(in) :: u_t(N_st,N_det) - - - PROVIDE N_int - - select case (N_int) - case (1) - call all_two_rdm_dm_nstates_openmp_work_1(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) - case (2) - call all_two_rdm_dm_nstates_openmp_work_2(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) - case (3) - call all_two_rdm_dm_nstates_openmp_work_3(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) - case (4) - call all_two_rdm_dm_nstates_openmp_work_4(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) - case default - call all_two_rdm_dm_nstates_openmp_work_N_int(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) - end select - end - -BEGIN_TEMPLATE - +subroutine all_two_rdm_dm_nstates_openmp(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_0,N_st,sze) + use bitmasks + implicit none + BEGIN_DOC + ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + ! + ! Assumes that the determinants are in psi_det + ! + ! istart, iend, ishift, istep are used in ZMQ parallelization. + END_DOC + integer, intent(in) :: N_st,sze + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: u_0(sze,N_st) + integer :: k + double precision, allocatable :: u_t(:,:) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t + allocate(u_t(N_st,N_det)) + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det) + enddo + call dtranspose( & + u_0, & + size(u_0, 1), & + u_t, & + size(u_t, 1), & + N_det, N_st) + + call all_two_rdm_dm_nstates_openmp_work(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1) + deallocate(u_t) + + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det) + enddo + +end + + +subroutine all_two_rdm_dm_nstates_openmp_work(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + BEGIN_DOC + ! Computes two-rdm + ! + ! Default should be 1,N_det,0,1 + END_DOC + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states) + double precision, intent(in) :: u_t(N_st,N_det) + + + PROVIDE N_int + + select case (N_int) + case (1) + call all_two_rdm_dm_nstates_openmp_work_1(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (2) + call all_two_rdm_dm_nstates_openmp_work_2(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (3) + call all_two_rdm_dm_nstates_openmp_work_3(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case (4) + call all_two_rdm_dm_nstates_openmp_work_4(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + case default + call all_two_rdm_dm_nstates_openmp_work_N_int(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + end select +end + + BEGIN_TEMPLATE + subroutine all_two_rdm_dm_nstates_openmp_work_$N_int(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) - use bitmasks - implicit none - BEGIN_DOC - ! Computes $v_t = H | u_t \\rangle$ and $s_t = S^2 | u_t \\rangle$ - ! - ! Default should be 1,N_det,0,1 - END_DOC - integer, intent(in) :: N_st,sze,istart,iend,ishift,istep - double precision, intent(in) :: u_t(N_st,N_det) - integer, intent(in) :: dim1,dim2,dim3,dim4 - double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states) - double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states) - double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states) - - integer :: i,j,k,l - integer :: k_a, k_b, l_a, l_b, m_a, m_b - integer :: istate - integer :: krow, kcol, krow_b, kcol_b - integer :: lrow, lcol - integer :: mrow, mcol - integer(bit_kind) :: spindet($N_int) - integer(bit_kind) :: tmp_det($N_int,2) - integer(bit_kind) :: tmp_det2($N_int,2) - integer(bit_kind) :: tmp_det3($N_int,2) - integer(bit_kind), allocatable :: buffer(:,:) - integer :: n_doubles - integer, allocatable :: doubles(:) - integer, allocatable :: singles_a(:) - integer, allocatable :: singles_b(:) - integer, allocatable :: idx(:), idx0(:) - integer :: maxab, n_singles_a, n_singles_b, kcol_prev - integer*8 :: k8 - - maxab = max(N_det_alpha_unique, N_det_beta_unique)+1 - allocate(idx0(maxab)) - - do i=1,maxab - idx0(i) = i - enddo - - ! Prepare the array of all alpha single excitations - ! ------------------------------------------------- - - PROVIDE N_int nthreads_davidson - !!$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) & - ! !$OMP SHARED(psi_bilinear_matrix_rows, N_det, & - ! !$OMP psi_bilinear_matrix_columns, & - ! !$OMP psi_det_alpha_unique, psi_det_beta_unique, & - ! !$OMP n_det_alpha_unique, n_det_beta_unique, N_int, & - ! !$OMP psi_bilinear_matrix_transp_rows, & - ! !$OMP psi_bilinear_matrix_transp_columns, & - ! !$OMP psi_bilinear_matrix_transp_order, N_st, & - ! !$OMP psi_bilinear_matrix_order_transp_reverse, & - ! !$OMP psi_bilinear_matrix_columns_loc, & - ! !$OMP psi_bilinear_matrix_transp_rows_loc, & - ! !$OMP istart, iend, istep, irp_here, v_t, s_t, & - ! !$OMP ishift, idx0, u_t, maxab) & - ! !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i, & - ! !$OMP lcol, lrow, l_a, l_b, & - ! !$OMP buffer, doubles, n_doubles, & - ! !$OMP tmp_det2, idx, l, kcol_prev, & - ! !$OMP singles_a, n_singles_a, singles_b, & - ! !$OMP n_singles_b, k8) - - ! Alpha/Beta double excitations - ! ============================= - - allocate( buffer($N_int,maxab), & - singles_a(maxab), & - singles_b(maxab), & - doubles(maxab), & - idx(maxab)) - - kcol_prev=-1 - - ASSERT (iend <= N_det) - ASSERT (istart > 0) - ASSERT (istep > 0) - - !!$OMP DO SCHEDULE(dynamic,64) - do k_a=istart+ishift,iend,istep - - krow = psi_bilinear_matrix_rows(k_a) - ASSERT (krow <= N_det_alpha_unique) - - kcol = psi_bilinear_matrix_columns(k_a) - ASSERT (kcol <= N_det_beta_unique) - - tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) - tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) - - if (kcol /= kcol_prev) then - call get_all_spin_singles_$N_int( & - psi_det_beta_unique, idx0, & - tmp_det(1,2), N_det_beta_unique, & - singles_b, n_singles_b) - endif - kcol_prev = kcol - - ! Loop over singly excited beta columns - ! ------------------------------------- - - do i=1,n_singles_b - lcol = singles_b(i) - - tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol) - - l_a = psi_bilinear_matrix_columns_loc(lcol) - ASSERT (l_a <= N_det) - - do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a - lrow = psi_bilinear_matrix_rows(l_a) - ASSERT (lrow <= N_det_alpha_unique) - - buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow) - - ASSERT (l_a <= N_det) - idx(j) = l_a - l_a = l_a+1 - enddo - j = j-1 - - call get_all_spin_singles_$N_int( & - buffer, idx, tmp_det(1,1), j, & - singles_a, n_singles_a ) - - ! Loop over alpha singles - ! ----------------------- - - do k = 1,n_singles_a - l_a = singles_a(k) - ASSERT (l_a <= N_det) - - lrow = psi_bilinear_matrix_rows(l_a) - ASSERT (lrow <= N_det_alpha_unique) - - tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) - !call i_H_j_double_alpha_beta(tmp_det,tmp_det2,$N_int,hij) - do l= 1, N_states + use bitmasks + implicit none + BEGIN_DOC + ! Computes $v_t = H | u_t \\rangle$ and $s_t = S^2 | u_t \\rangle$ + ! + ! Default should be 1,N_det,0,1 + END_DOC + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + double precision, intent(in) :: u_t(N_st,N_det) + integer, intent(in) :: dim1,dim2,dim3,dim4 + double precision, intent(inout) :: big_array_aa(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_bb(dim1,dim2,dim3,dim4,N_states) + double precision, intent(inout) :: big_array_ab(dim1,dim2,dim3,dim4,N_states) + + integer :: i,j,k,l + integer :: k_a, k_b, l_a, l_b, m_a, m_b + integer :: istate + integer :: krow, kcol, krow_b, kcol_b + integer :: lrow, lcol + integer :: mrow, mcol + integer(bit_kind) :: spindet($N_int) + integer(bit_kind) :: tmp_det($N_int,2) + integer(bit_kind) :: tmp_det2($N_int,2) + integer(bit_kind) :: tmp_det3($N_int,2) + integer(bit_kind), allocatable :: buffer(:,:) + integer :: n_doubles + integer, allocatable :: doubles(:) + integer, allocatable :: singles_a(:) + integer, allocatable :: singles_b(:) + integer, allocatable :: idx(:), idx0(:) + integer :: maxab, n_singles_a, n_singles_b, kcol_prev + integer*8 :: k8 + + maxab = max(N_det_alpha_unique, N_det_beta_unique)+1 + allocate(idx0(maxab)) + + do i=1,maxab + idx0(i) = i + enddo + + ! Prepare the array of all alpha single excitations + ! ------------------------------------------------- + + PROVIDE N_int nthreads_davidson + !!$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) & + ! !$OMP SHARED(psi_bilinear_matrix_rows, N_det, & + ! !$OMP psi_bilinear_matrix_columns, & + ! !$OMP psi_det_alpha_unique, psi_det_beta_unique,& + ! !$OMP n_det_alpha_unique, n_det_beta_unique, N_int,& + ! !$OMP psi_bilinear_matrix_transp_rows, & + ! !$OMP psi_bilinear_matrix_transp_columns, & + ! !$OMP psi_bilinear_matrix_transp_order, N_st, & + ! !$OMP psi_bilinear_matrix_order_transp_reverse, & + ! !$OMP psi_bilinear_matrix_columns_loc, & + ! !$OMP psi_bilinear_matrix_transp_rows_loc, & + ! !$OMP istart, iend, istep, irp_here, v_t, s_t, & + ! !$OMP ishift, idx0, u_t, maxab) & + ! !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,& + ! !$OMP lcol, lrow, l_a, l_b, & + ! !$OMP buffer, doubles, n_doubles, & + ! !$OMP tmp_det2, idx, l, kcol_prev, & + ! !$OMP singles_a, n_singles_a, singles_b, & + ! !$OMP n_singles_b, k8) + + ! Alpha/Beta double excitations + ! ============================= + + allocate( buffer($N_int,maxab), & + singles_a(maxab), & + singles_b(maxab), & + doubles(maxab), & + idx(maxab)) + + kcol_prev=-1 + + ASSERT (iend <= N_det) + ASSERT (istart > 0) + ASSERT (istep > 0) + + !!$OMP DO SCHEDULE(dynamic,64) + do k_a=istart+ishift,iend,istep + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + if (kcol /= kcol_prev) then + call get_all_spin_singles_$N_int( & + psi_det_beta_unique, idx0, & + tmp_det(1,2), N_det_beta_unique, & + singles_b, n_singles_b) + endif + kcol_prev = kcol + + ! Loop over singly excited beta columns + ! ------------------------------------- + + do i=1,n_singles_b + lcol = singles_b(i) + + tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol) + + l_a = psi_bilinear_matrix_columns_loc(lcol) + ASSERT (l_a <= N_det) + + do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow) + + ASSERT (l_a <= N_det) + idx(j) = l_a + l_a = l_a+1 + enddo + j = j-1 + + call get_all_spin_singles_$N_int( & + buffer, idx, tmp_det(1,1), j, & + singles_a, n_singles_a ) + + ! Loop over alpha singles + ! ----------------------- + + do k = 1,n_singles_a + l_a = singles_a(k) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) + !call i_H_j_double_alpha_beta(tmp_det,tmp_det2,$N_int,hij) + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_double_to_two_rdm_ab_dm(tmp_det,tmp_det2,c_1,c_2,big_array_ab,dim1,dim2,dim3,dim4) + enddo + + enddo + + enddo + ! !$OMP END DO + + ! !$OMP DO SCHEDULE(dynamic,64) + do k_a=istart+ishift,iend,istep + + + ! Single and double alpha exitations + ! =================================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + ! Initial determinant is at k_b in beta-major representation + ! ---------------------------------------------------------------------- + + k_b = psi_bilinear_matrix_order_transp_reverse(k_a) + ASSERT (k_b <= N_det) + + spindet(1:$N_int) = tmp_det(1:$N_int,1) + + ! Loop inside the beta column to gather all the connected alphas + lcol = psi_bilinear_matrix_columns(k_a) + l_a = psi_bilinear_matrix_columns_loc(lcol) + do i=1,N_det_alpha_unique + if (l_a > N_det) exit + lcol = psi_bilinear_matrix_columns(l_a) + if (lcol /= kcol) exit + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow) + idx(i) = l_a + l_a = l_a+1 + enddo + i = i-1 + + call get_all_spin_singles_and_doubles_$N_int( & + buffer, idx, spindet, i, & + singles_a, doubles, n_singles_a, n_doubles ) + + ! Compute Hij for all alpha singles + ! ---------------------------------- + + tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + do i=1,n_singles_a + l_a = singles_a(i) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) + do l= 1, N_states c_1(l) = u_t(l,l_a) c_2(l) = u_t(l,k_a) - enddo - call off_diagonal_double_to_two_rdm_ab_dm(tmp_det,tmp_det2,c_1,c_2,big_array_ab,dim1,dim2,dim3,dim4) - enddo - - enddo - - enddo -! !$OMP END DO - -! !$OMP DO SCHEDULE(dynamic,64) - do k_a=istart+ishift,iend,istep - - - ! Single and double alpha exitations - ! =================================== - - - ! Initial determinant is at k_a in alpha-major representation - ! ----------------------------------------------------------------------- - - krow = psi_bilinear_matrix_rows(k_a) - ASSERT (krow <= N_det_alpha_unique) - - kcol = psi_bilinear_matrix_columns(k_a) - ASSERT (kcol <= N_det_beta_unique) - - tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) - tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) - - ! Initial determinant is at k_b in beta-major representation - ! ---------------------------------------------------------------------- - - k_b = psi_bilinear_matrix_order_transp_reverse(k_a) - ASSERT (k_b <= N_det) - - spindet(1:$N_int) = tmp_det(1:$N_int,1) - - ! Loop inside the beta column to gather all the connected alphas - lcol = psi_bilinear_matrix_columns(k_a) - l_a = psi_bilinear_matrix_columns_loc(lcol) - do i=1,N_det_alpha_unique - if (l_a > N_det) exit - lcol = psi_bilinear_matrix_columns(l_a) - if (lcol /= kcol) exit - lrow = psi_bilinear_matrix_rows(l_a) - ASSERT (lrow <= N_det_alpha_unique) - - buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow) - idx(i) = l_a - l_a = l_a+1 - enddo - i = i-1 - - call get_all_spin_singles_and_doubles_$N_int( & - buffer, idx, spindet, i, & - singles_a, doubles, n_singles_a, n_doubles ) - - ! Compute Hij for all alpha singles - ! ---------------------------------- - - tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) - do i=1,n_singles_a - l_a = singles_a(i) - ASSERT (l_a <= N_det) - - lrow = psi_bilinear_matrix_rows(l_a) - ASSERT (lrow <= N_det_alpha_unique) - - tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) - do l= 1, N_states - c_1(l) = u_t(l,l_a) - c_2(l) = u_t(l,k_a) - enddo - ! increment the alpha/beta part for single excitations - call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array_ab,dim1,dim2,dim3,dim4) - ! increment the alpha/alpha part for single excitations - call off_diagonal_single_to_two_rdm_aa_dm(tmp_det,tmp_det2,c_1,c_2,big_array_aa,dim1,dim2,dim3,dim4) - - enddo - - - ! Compute Hij for all alpha doubles - ! ---------------------------------- - - do i=1,n_doubles - l_a = doubles(i) - ASSERT (l_a <= N_det) - - lrow = psi_bilinear_matrix_rows(l_a) - ASSERT (lrow <= N_det_alpha_unique) - - do l= 1, N_states - c_1(l) = u_t(l,l_a) - c_2(l) = u_t(l,k_a) - enddo - call off_diagonal_double_to_two_rdm_aa_dm(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_1,c_2,big_array_aa,dim1,dim2,dim3,dim4) - enddo - - - ! Single and double beta excitations - ! ================================== - - - ! Initial determinant is at k_a in alpha-major representation - ! ----------------------------------------------------------------------- - - krow = psi_bilinear_matrix_rows(k_a) - kcol = psi_bilinear_matrix_columns(k_a) - - tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) - tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) - - spindet(1:$N_int) = tmp_det(1:$N_int,2) - - ! Initial determinant is at k_b in beta-major representation - ! ----------------------------------------------------------------------- - - k_b = psi_bilinear_matrix_order_transp_reverse(k_a) - ASSERT (k_b <= N_det) - - ! Loop inside the alpha row to gather all the connected betas - lrow = psi_bilinear_matrix_transp_rows(k_b) - l_b = psi_bilinear_matrix_transp_rows_loc(lrow) - do i=1,N_det_beta_unique - if (l_b > N_det) exit - lrow = psi_bilinear_matrix_transp_rows(l_b) - if (lrow /= krow) exit - lcol = psi_bilinear_matrix_transp_columns(l_b) - ASSERT (lcol <= N_det_beta_unique) - - buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol) - idx(i) = l_b - l_b = l_b+1 - enddo - i = i-1 - - call get_all_spin_singles_and_doubles_$N_int( & - buffer, idx, spindet, i, & - singles_b, doubles, n_singles_b, n_doubles ) - - ! Compute Hij for all beta singles - ! ---------------------------------- - - tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) - do i=1,n_singles_b - l_b = singles_b(i) - ASSERT (l_b <= N_det) - - lcol = psi_bilinear_matrix_transp_columns(l_b) - ASSERT (lcol <= N_det_beta_unique) - - tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol) - l_a = psi_bilinear_matrix_transp_order(l_b) - do l= 1, N_states - c_1(l) = u_t(l,l_a) - c_2(l) = u_t(l,k_a) - enddo - ! increment the alpha/beta part for single excitations - call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array_ab,dim1,dim2,dim3,dim4) - ! increment the beta /beta part for single excitations - call off_diagonal_single_to_two_rdm_bb_dm(tmp_det, tmp_det2,c_1,c_2,big_array_bb,dim1,dim2,dim3,dim4) - enddo - - ! Compute Hij for all beta doubles - ! ---------------------------------- - - do i=1,n_doubles - l_b = doubles(i) - ASSERT (l_b <= N_det) - - lcol = psi_bilinear_matrix_transp_columns(l_b) - ASSERT (lcol <= N_det_beta_unique) - - l_a = psi_bilinear_matrix_transp_order(l_b) - do l= 1, N_states - c_1(l) = u_t(l,l_a) - c_2(l) = u_t(l,k_a) - enddo - call off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_alpha_unique(1, lcol),c_1,c_2,big_array_bb,dim1,dim2,dim3,dim4) - ASSERT (l_a <= N_det) - - enddo - - - ! Diagonal contribution - ! ===================== - - - ! Initial determinant is at k_a in alpha-major representation - ! ----------------------------------------------------------------------- - - krow = psi_bilinear_matrix_rows(k_a) - ASSERT (krow <= N_det_alpha_unique) - - kcol = psi_bilinear_matrix_columns(k_a) - ASSERT (kcol <= N_det_beta_unique) - - tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) - tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) - - double precision, external :: diag_wee_mat_elem, diag_S_mat_elem - - double precision :: c_1(N_states),c_2(N_states) - do l = 1, N_states - c_1(l) = u_t(l,k_a) - enddo - - call diagonal_contrib_to_all_two_rdm_dm(tmp_det,c_1,big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4) - - end do - !!$OMP END DO - deallocate(buffer, singles_a, singles_b, doubles, idx) - !!$OMP END PARALLEL - + enddo + ! increment the alpha/beta part for single excitations + call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array_ab,dim1,dim2,dim3,dim4) + ! increment the alpha/alpha part for single excitations + call off_diagonal_single_to_two_rdm_aa_dm(tmp_det,tmp_det2,c_1,c_2,big_array_aa,dim1,dim2,dim3,dim4) + + enddo + + + ! Compute Hij for all alpha doubles + ! ---------------------------------- + + do i=1,n_doubles + l_a = doubles(i) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_double_to_two_rdm_aa_dm(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_1,c_2,big_array_aa,dim1,dim2,dim3,dim4) + enddo + + + ! Single and double beta excitations + ! ================================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + kcol = psi_bilinear_matrix_columns(k_a) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + spindet(1:$N_int) = tmp_det(1:$N_int,2) + + ! Initial determinant is at k_b in beta-major representation + ! ----------------------------------------------------------------------- + + k_b = psi_bilinear_matrix_order_transp_reverse(k_a) + ASSERT (k_b <= N_det) + + ! Loop inside the alpha row to gather all the connected betas + lrow = psi_bilinear_matrix_transp_rows(k_b) + l_b = psi_bilinear_matrix_transp_rows_loc(lrow) + do i=1,N_det_beta_unique + if (l_b > N_det) exit + lrow = psi_bilinear_matrix_transp_rows(l_b) + if (lrow /= krow) exit + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol) + idx(i) = l_b + l_b = l_b+1 + enddo + i = i-1 + + call get_all_spin_singles_and_doubles_$N_int( & + buffer, idx, spindet, i, & + singles_b, doubles, n_singles_b, n_doubles ) + + ! Compute Hij for all beta singles + ! ---------------------------------- + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + do i=1,n_singles_b + l_b = singles_b(i) + ASSERT (l_b <= N_det) + + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol) + l_a = psi_bilinear_matrix_transp_order(l_b) + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + ! increment the alpha/beta part for single excitations + call off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_1,c_2,big_array_ab,dim1,dim2,dim3,dim4) + ! increment the beta /beta part for single excitations + call off_diagonal_single_to_two_rdm_bb_dm(tmp_det, tmp_det2,c_1,c_2,big_array_bb,dim1,dim2,dim3,dim4) + enddo + + ! Compute Hij for all beta doubles + ! ---------------------------------- + + do i=1,n_doubles + l_b = doubles(i) + ASSERT (l_b <= N_det) + + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + l_a = psi_bilinear_matrix_transp_order(l_b) + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + enddo + call off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_alpha_unique(1, lcol),c_1,c_2,big_array_bb,dim1,dim2,dim3,dim4) + ASSERT (l_a <= N_det) + + enddo + + + ! Diagonal contribution + ! ===================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + double precision, external :: diag_wee_mat_elem, diag_S_mat_elem + + double precision :: c_1(N_states),c_2(N_states) + do l = 1, N_states + c_1(l) = u_t(l,k_a) + enddo + + call diagonal_contrib_to_all_two_rdm_dm(tmp_det,c_1,big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4) + + end do + !!$OMP END DO + deallocate(buffer, singles_a, singles_b, doubles, idx) + !!$OMP END PARALLEL + end - -SUBST [ N_int ] - -1;; -2;; -3;; -4;; -N_int;; - -END_TEMPLATE - + + SUBST [ N_int ] + + 1;; + 2;; + 3;; + 4;; + N_int;; + + END_TEMPLATE + diff --git a/src/two_body_rdm/two_rdm.irp.f b/src/two_body_rdm/two_rdm.irp.f index 1c299bba..bed6f88d 100644 --- a/src/two_body_rdm/two_rdm.irp.f +++ b/src/two_body_rdm/two_rdm.irp.f @@ -1,84 +1,86 @@ - - BEGIN_PROVIDER [double precision, coussin_peter_two_rdm_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] - implicit none - BEGIN_DOC - ! coussin_peter_two_rdm_mo(i,j,k,l) = the two rdm that peter wants for his CASSCF - END_DOC - integer :: i,j,k,l - do l = 1, mo_num - do k = 1, mo_num - do j = 1, mo_num - do i = 1, mo_num - coussin_peter_two_rdm_mo(i,j,k,l,:) = 0.5d0 * (two_rdm_alpha_beta_mo(i,j,k,l,:) + two_rdm_alpha_beta_mo(i,j,k,l,:)) & - + two_rdm_alpha_alpha_mo(i,j,k,l,:) & - + two_rdm_beta_beta_mo(i,j,k,l,:) +BEGIN_PROVIDER [double precision, coussin_peter_two_rdm_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] + implicit none + BEGIN_DOC + ! coussin_peter_two_rdm_mo(i,j,k,l) = the two rdm that peter wants for his CASSCF + END_DOC + integer :: i,j,k,l, istate + do istate = 1,N_states + do l = 1, mo_num + do k = 1, mo_num + do j = 1, mo_num + do i = 1, mo_num + coussin_peter_two_rdm_mo (i,j,k,l,istate) = & + two_rdm_alpha_beta_mo (i,j,k,l,istate) + & + two_rdm_alpha_alpha_mo(i,j,k,l,istate) + & + two_rdm_beta_beta_mo (i,j,k,l,istate) + enddo + enddo + enddo enddo - enddo enddo - enddo - END_PROVIDER +END_PROVIDER BEGIN_PROVIDER [double precision, two_rdm_alpha_beta_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] &BEGIN_PROVIDER [double precision, two_rdm_alpha_alpha_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] &BEGIN_PROVIDER [double precision, two_rdm_beta_beta_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] - implicit none - BEGIN_DOC - ! two_rdm_alpha_beta(i,j,k,l) = - ! 1 1 2 2 = chemist notations - ! note that no 1/2 factor is introduced in order to take into acccount for the spin symmetry - ! - END_DOC - integer :: dim1,dim2,dim3,dim4 - double precision :: cpu_0,cpu_1 - dim1 = mo_num - dim2 = mo_num - dim3 = mo_num - dim4 = mo_num - two_rdm_alpha_beta_mo = 0.d0 - two_rdm_alpha_alpha_mo= 0.d0 - two_rdm_beta_beta_mo = 0.d0 - print*,'providing two_rdm_alpha_beta ...' - call wall_time(cpu_0) - call all_two_rdm_dm_nstates_openmp(two_rdm_alpha_alpha_mo,two_rdm_beta_beta_mo,two_rdm_alpha_beta_mo,dim1,dim2,dim3,dim4,psi_coef,size(psi_coef,2),size(psi_coef,1)) - call wall_time(cpu_1) - print*,'two_rdm_alpha_beta provided in',dabs(cpu_1-cpu_0) - - END_PROVIDER + implicit none + BEGIN_DOC + ! two_rdm_alpha_beta(i,j,k,l) = + ! 1 1 2 2 = chemist notations + ! note that no 1/2 factor is introduced in order to take into acccount for the spin symmetry + ! + END_DOC + integer :: dim1,dim2,dim3,dim4 + double precision :: cpu_0,cpu_1 + dim1 = mo_num + dim2 = mo_num + dim3 = mo_num + dim4 = mo_num + two_rdm_alpha_beta_mo = 0.d0 + two_rdm_alpha_alpha_mo= 0.d0 + two_rdm_beta_beta_mo = 0.d0 + print*,'providing two_rdm_alpha_beta ...' + call wall_time(cpu_0) + call all_two_rdm_dm_nstates_openmp(two_rdm_alpha_alpha_mo,two_rdm_beta_beta_mo,two_rdm_alpha_beta_mo,dim1,dim2,dim3,dim4,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call wall_time(cpu_1) + print*,'two_rdm_alpha_beta provided in',dabs(cpu_1-cpu_0) + +END_PROVIDER BEGIN_PROVIDER [double precision, two_rdm_alpha_beta_mo_physicist, (mo_num,mo_num,mo_num,mo_num,N_states)] &BEGIN_PROVIDER [double precision, two_rdm_alpha_alpha_mo_physicist, (mo_num,mo_num,mo_num,mo_num,N_states)] &BEGIN_PROVIDER [double precision, two_rdm_beta_beta_mo_physicist, (mo_num,mo_num,mo_num,mo_num,N_states)] - implicit none - BEGIN_DOC - ! two_rdm_alpha_beta_mo_physicist,(i,j,k,l) = - ! 1 2 1 2 = physicist notations - ! note that no 1/2 factor is introduced in order to take into acccount for the spin symmetry - ! - END_DOC - integer :: i,j,k,l,istate - double precision :: cpu_0,cpu_1 - two_rdm_alpha_beta_mo_physicist = 0.d0 - print*,'providing two_rdm_alpha_beta_mo_physicist ...' - call wall_time(cpu_0) - do istate = 1, N_states - do i = 1, mo_num - do j = 1, mo_num - do k = 1, mo_num - do l = 1, mo_num - ! 1 2 1 2 1 1 2 2 - two_rdm_alpha_beta_mo_physicist(l,k,i,j,istate) = two_rdm_alpha_beta_mo(i,l,j,k,istate) - two_rdm_alpha_alpha_mo_physicist(l,k,i,j,istate) = two_rdm_alpha_alpha_mo(i,l,j,k,istate) - two_rdm_beta_beta_mo_physicist(l,k,i,j,istate) = two_rdm_beta_beta_mo(i,l,j,k,istate) - enddo + implicit none + BEGIN_DOC + ! two_rdm_alpha_beta_mo_physicist,(i,j,k,l) = + ! 1 2 1 2 = physicist notations + ! note that no 1/2 factor is introduced in order to take into acccount for the spin symmetry + ! + END_DOC + integer :: i,j,k,l,istate + double precision :: cpu_0,cpu_1 + two_rdm_alpha_beta_mo_physicist = 0.d0 + print*,'providing two_rdm_alpha_beta_mo_physicist ...' + call wall_time(cpu_0) + do istate = 1, N_states + do i = 1, mo_num + do j = 1, mo_num + do k = 1, mo_num + do l = 1, mo_num + ! 1 2 1 2 1 1 2 2 + two_rdm_alpha_beta_mo_physicist(l,k,i,j,istate) = two_rdm_alpha_beta_mo(i,l,j,k,istate) + two_rdm_alpha_alpha_mo_physicist(l,k,i,j,istate) = two_rdm_alpha_alpha_mo(i,l,j,k,istate) + two_rdm_beta_beta_mo_physicist(l,k,i,j,istate) = two_rdm_beta_beta_mo(i,l,j,k,istate) + enddo + enddo + enddo enddo - enddo enddo - enddo - call wall_time(cpu_1) - print*,'two_rdm_alpha_beta_mo_physicist provided in',dabs(cpu_1-cpu_0) - - END_PROVIDER + call wall_time(cpu_1) + print*,'two_rdm_alpha_beta_mo_physicist provided in',dabs(cpu_1-cpu_0) + +END_PROVIDER From 92e44f53bae20a9995f968c16017ca402c7c5962 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 27 Jun 2019 23:06:35 +0200 Subject: [PATCH 14/59] Fixed small bugs --- src/casscf/casscf.irp.f | 5 +++-- src/casscf/neworbs.irp.f | 6 +++--- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/src/casscf/casscf.irp.f b/src/casscf/casscf.irp.f index 10a3e34a..8aaa1925 100644 --- a/src/casscf/casscf.irp.f +++ b/src/casscf/casscf.irp.f @@ -3,8 +3,8 @@ program casscf BEGIN_DOC ! TODO : Put the documentation of the program here END_DOC - no_vvvv_integrals = .True. - SOFT_TOUCH no_vvvv_integrals +! no_vvvv_integrals = .True. +! SOFT_TOUCH no_vvvv_integrals call run end @@ -13,6 +13,7 @@ subroutine run double precision :: energy_old, energy logical :: converged integer :: iteration + PROVIDE mo_two_e_integrals_in_map converged = .False. energy = 0.d0 diff --git a/src/casscf/neworbs.irp.f b/src/casscf/neworbs.irp.f index fd94eb6a..f4319485 100644 --- a/src/casscf/neworbs.irp.f +++ b/src/casscf/neworbs.irp.f @@ -25,7 +25,7 @@ BEGIN_PROVIDER [real*8, SXmatrix, (nMonoEx+1,nMonoEx+1)] end do if (bavard) then - do i=2,nMonoEx+1 + do i=2,nMonoEx write(6,*) ' diagonal of the Hessian : ',i,hessmat2(i,i) end do end if @@ -77,14 +77,14 @@ END_PROVIDER energy_improvement = SXeigenval(best_vector) + c0=SXeigenvec(1,best_vector) + if (bavard) then write(6,*) ' SXdiag : eigenvalue for best overlap with ' write(6,*) ' previous orbitals = ',SXeigenval(best_vector) write(6,*) ' weight of the 1st element ',c0 endif - c0=SXeigenvec(1,best_vector) - do i=1,nMonoEx+1 SXvector(i)=SXeigenvec(i,best_vector)/c0 end do From 82bbf95fead74f927ba1c15779b958623dcfc3ef Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 27 Jun 2019 23:46:30 +0200 Subject: [PATCH 15/59] Fixed small bugs --- src/bitmask/core_inact_act_virt.irp.f | 4 ++++ src/casscf/casscf.irp.f | 9 ++++----- src/cipsi/pt2_stoch_routines.irp.f | 13 +++++++++++-- src/generators_cas/generators.irp.f | 1 + 4 files changed, 20 insertions(+), 7 deletions(-) diff --git a/src/bitmask/core_inact_act_virt.irp.f b/src/bitmask/core_inact_act_virt.irp.f index f830da4e..177c3df5 100644 --- a/src/bitmask/core_inact_act_virt.irp.f +++ b/src/bitmask/core_inact_act_virt.irp.f @@ -141,6 +141,10 @@ END_PROVIDER n_act_orb_tmp = 0 n_virt_orb_tmp = 0 n_del_orb_tmp = 0 + core_bitmask = 0_bit_kind + inact_bitmask = 0_bit_kind + act_bitmask = 0_bit_kind + virt_bitmask = 0_bit_kind do i = 1, mo_num if(mo_class(i) == 'Core')then n_core_orb_tmp += 1 diff --git a/src/casscf/casscf.irp.f b/src/casscf/casscf.irp.f index 8aaa1925..54bf35ee 100644 --- a/src/casscf/casscf.irp.f +++ b/src/casscf/casscf.irp.f @@ -3,8 +3,8 @@ program casscf BEGIN_DOC ! TODO : Put the documentation of the program here END_DOC -! no_vvvv_integrals = .True. -! SOFT_TOUCH no_vvvv_integrals + no_vvvv_integrals = .True. + SOFT_TOUCH no_vvvv_integrals call run end @@ -13,15 +13,13 @@ subroutine run double precision :: energy_old, energy logical :: converged integer :: iteration - PROVIDE mo_two_e_integrals_in_map converged = .False. energy = 0.d0 mo_label = "MCSCF" iteration = 1 do while (.not.converged) - call run_cipsi - + call run_stochastic_cipsi energy_old = energy energy = eone+etwo+ecore @@ -39,6 +37,7 @@ subroutine run iteration += 1 FREE mo_integrals_map mo_two_e_integrals_in_map psi_det psi_coef SOFT_TOUCH mo_coef N_det + enddo end diff --git a/src/cipsi/pt2_stoch_routines.irp.f b/src/cipsi/pt2_stoch_routines.irp.f index 9f891320..7825d24c 100644 --- a/src/cipsi/pt2_stoch_routines.irp.f +++ b/src/cipsi/pt2_stoch_routines.irp.f @@ -135,7 +135,7 @@ subroutine ZMQ_pt2(E, pt2,relative_error, error, variance, norm, N_in) PROVIDE psi_occ_pattern_hii det_to_occ_pattern endif - if (N_det < max(4,N_states)) then + if (N_det <= max(4,N_states)) then pt2=0.d0 variance=0.d0 norm=0.d0 @@ -719,6 +719,15 @@ END_PROVIDER double precision :: rss double precision, external :: memory_of_double, memory_of_int + if (N_det_generators == 1) then + pt2_w = 1.d0 + pt2_cw = 1.d0 + pt2_W_T = 1.d0 + pt2_u_0 = 1.d0 + pt2_n_0 = 1 + return + endif + rss = memory_of_double(2*N_det_generators+1) call check_mem(rss,irp_here) @@ -754,7 +763,7 @@ END_PROVIDER end if pt2_n_0(1) += 1 if(N_det_generators - pt2_n_0(1) < pt2_minDetInFirstTeeth * pt2_N_teeth) then - stop "teeth building failed" + print *, "teeth building failed" end if end do !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! diff --git a/src/generators_cas/generators.irp.f b/src/generators_cas/generators.irp.f index c22eab51..b2f58202 100644 --- a/src/generators_cas/generators.irp.f +++ b/src/generators_cas/generators.irp.f @@ -55,6 +55,7 @@ END_PROVIDER nongen(inongen) = i endif enddo + ASSERT (m == N_det_generators) psi_det_sorted_gen(:,:,:N_det_generators) = psi_det_generators(:,:,:N_det_generators) psi_coef_sorted_gen(:N_det_generators, :) = psi_coef_generators(:N_det_generators, :) From ae3a4929b6443f13512e2c1b28642812914bc84a Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 27 Jun 2019 23:59:21 +0200 Subject: [PATCH 16/59] Using fast 2RDM s --- src/casscf/densities.irp.f | 146 ++++++--------------------------- src/casscf/test_two_rdm.irp.f | 10 +-- src/two_body_rdm/two_rdm.irp.f | 30 ++++--- 3 files changed, 46 insertions(+), 140 deletions(-) diff --git a/src/casscf/densities.irp.f b/src/casscf/densities.irp.f index 9b8dba78..7b243bb4 100644 --- a/src/casscf/densities.irp.f +++ b/src/casscf/densities.irp.f @@ -29,7 +29,9 @@ BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ] ! END_DOC implicit none - integer :: t,u,v,x,mu,nu,istate,ispin,jspin,ihole,ipart,jhole,jpart + integer :: t,u,v,x + integer :: tt,uu,vv,xx + integer :: mu,nu,istate,ispin,jspin,ihole,ipart,jhole,jpart integer :: ierr real*8 :: phase1,phase11,phase12,phase2,phase21,phase22 integer :: nu1,nu2,nu11,nu12,nu21,nu22 @@ -43,125 +45,25 @@ BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ] write(6,*) ' providing density matrix P0' endif - P0tuvx = 0.d0 - - ! first loop: we apply E_tu, once for D_tu, once for -P_tvvu - do mu=1,n_det - call det_extract(det_mu,mu,N_int) - do istate=1,n_states - cI_mu(istate)=psi_coef(mu,istate) - end do - do t=1,n_act_orb - ipart=list_act(t) - do u=1,n_act_orb - ihole=list_act(u) - ! apply E_tu - call det_copy(det_mu,det_mu_ex1,N_int) - call det_copy(det_mu,det_mu_ex2,N_int) - call do_spinfree_mono_excitation(det_mu,det_mu_ex1 & - ,det_mu_ex2,nu1,nu2,ihole,ipart,phase1,phase2,ierr1,ierr2) - ! det_mu_ex1 is in the list - if (nu1.ne.-1) then - do istate=1,n_states - term=cI_mu(istate)*psi_coef(nu1,istate)*phase1 - ! and we fill P0_tvvu - do v=1,n_act_orb - P0tuvx(t,v,v,u)-=term - end do - end do - end if - ! det_mu_ex2 is in the list - if (nu2.ne.-1) then - do istate=1,n_states - term=cI_mu(istate)*psi_coef(nu2,istate)*phase2 - do v=1,n_act_orb - P0tuvx(t,v,v,u)-=term - end do - end do - end if - end do - end do - end do - ! now we do the double excitation E_tu E_vx |0> - do mu=1,n_det - call det_extract(det_mu,mu,N_int) - do istate=1,n_states - cI_mu(istate)=psi_coef(mu,istate) - end do - do v=1,n_act_orb - ipart=list_act(v) - do x=1,n_act_orb - ihole=list_act(x) - ! apply E_vx - call det_copy(det_mu,det_mu_ex1,N_int) - call det_copy(det_mu,det_mu_ex2,N_int) - call do_spinfree_mono_excitation(det_mu,det_mu_ex1 & - ,det_mu_ex2,nu1,nu2,ihole,ipart,phase1,phase2,ierr1,ierr2) - ! we apply E_tu to the first resultant determinant, thus E_tu E_vx |0> - if (ierr1.eq.1) then - do t=1,n_act_orb - jpart=list_act(t) - do u=1,n_act_orb - jhole=list_act(u) - call det_copy(det_mu_ex1,det_mu_ex11,N_int) - call det_copy(det_mu_ex1,det_mu_ex12,N_int) - call do_spinfree_mono_excitation(det_mu_ex1,det_mu_ex11& - ,det_mu_ex12,nu11,nu12,jhole,jpart,phase11,phase12,ierr11,ierr12) - if (nu11.ne.-1) then - do istate=1,n_states - P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu11,istate)& - *phase11*phase1 - end do - end if - if (nu12.ne.-1) then - do istate=1,n_states - P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu12,istate)& - *phase12*phase1 - end do - end if - end do - end do - end if - - ! we apply E_tu to the second resultant determinant - if (ierr2.eq.1) then - do t=1,n_act_orb - jpart=list_act(t) - do u=1,n_act_orb - jhole=list_act(u) - call det_copy(det_mu_ex2,det_mu_ex21,N_int) - call det_copy(det_mu_ex2,det_mu_ex22,N_int) - call do_spinfree_mono_excitation(det_mu_ex2,det_mu_ex21& - ,det_mu_ex22,nu21,nu22,jhole,jpart,phase21,phase22,ierr21,ierr22) - if (nu21.ne.-1) then - do istate=1,n_states - P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu21,istate)& - *phase21*phase2 - end do - end if - if (nu22.ne.-1) then - do istate=1,n_states - P0tuvx(t,u,v,x)+=cI_mu(istate)*psi_coef(nu22,istate)& - *phase22*phase2 - end do - end if - end do - end do - end if - - end do - end do - end do - - ! we average by just dividing by the number of states - do x=1,n_act_orb - do v=1,n_act_orb - do u=1,n_act_orb - do t=1,n_act_orb - P0tuvx(t,u,v,x)*=0.5D0/dble(N_states) - end do - end do - end do - end do - + P0tuvx= 0.d0 + do istate=1,N_states + do x = 1, n_act_orb + xx = list_act(x) + do v = 1, n_act_orb + vv = list_act(v) + do u = 1, n_act_orb + uu = list_act(u) + do t = 1, n_act_orb + tt = list_act(t) + P0tuvx(t,u,v,x) = & + state_average_weight(istate) * & + ( two_rdm_alpha_beta_mo (tt,uu,vv,xx,istate) + & + two_rdm_alpha_alpha_mo(tt,uu,vv,xx,istate) + & + two_rdm_beta_beta_mo (tt,uu,vv,xx,istate) ) + enddo + enddo + enddo + enddo + enddo + END_PROVIDER diff --git a/src/casscf/test_two_rdm.irp.f b/src/casscf/test_two_rdm.irp.f index 562d15a6..9abe0aa0 100644 --- a/src/casscf/test_two_rdm.irp.f +++ b/src/casscf/test_two_rdm.irp.f @@ -8,11 +8,11 @@ program print_two_rdm double precision :: accu,twodm accu = 0.d0 - do i=1,mo_num - do j=1,mo_num - do k=1,mo_num - do l=1,mo_num - twodm = coussin_peter_two_rdm_mo(i,j,k,l,1) + do i=1,n_act_orb + do j=1,n_act_orb + do k=1,n_act_orb + do l=1,n_act_orb + twodm = coussin_peter_two_rdm_mo(list_act(i),list_act(j),list_act(k),list_act(l)) if(dabs(twodm - P0tuvx(i,j,k,l)).gt.thr)then print*,'' print*,'sum' diff --git a/src/two_body_rdm/two_rdm.irp.f b/src/two_body_rdm/two_rdm.irp.f index 1c299bba..a75a92cc 100644 --- a/src/two_body_rdm/two_rdm.irp.f +++ b/src/two_body_rdm/two_rdm.irp.f @@ -1,23 +1,27 @@ - - BEGIN_PROVIDER [double precision, coussin_peter_two_rdm_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] +BEGIN_PROVIDER [double precision, coussin_peter_two_rdm_mo, (mo_num,mo_num,mo_num,mo_num)] implicit none BEGIN_DOC ! coussin_peter_two_rdm_mo(i,j,k,l) = the two rdm that peter wants for his CASSCF END_DOC - integer :: i,j,k,l - do l = 1, mo_num - do k = 1, mo_num - do j = 1, mo_num - do i = 1, mo_num - coussin_peter_two_rdm_mo(i,j,k,l,:) = 0.5d0 * (two_rdm_alpha_beta_mo(i,j,k,l,:) + two_rdm_alpha_beta_mo(i,j,k,l,:)) & - + two_rdm_alpha_alpha_mo(i,j,k,l,:) & - + two_rdm_beta_beta_mo(i,j,k,l,:) - enddo - enddo + integer :: i,j,k,l, istate + coussin_peter_two_rdm_mo = 0.d0 + do istate=1,N_states + do l = 1, mo_num + do k = 1, mo_num + do j = 1, mo_num + do i = 1, mo_num + coussin_peter_two_rdm_mo(i,j,k,l) = & + state_average_weight(istate) * & + ( two_rdm_alpha_beta_mo(i,j,k,l,istate) + & + two_rdm_alpha_alpha_mo(i,j,k,l,istate)+ & + two_rdm_beta_beta_mo(i,j,k,l,istate) ) + enddo + enddo + enddo enddo enddo - END_PROVIDER +END_PROVIDER BEGIN_PROVIDER [double precision, two_rdm_alpha_beta_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] From a4d2e39978ecb4802fee53b80e9d525e8e010900 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 28 Jun 2019 00:04:12 +0200 Subject: [PATCH 17/59] Minor fix --- src/cipsi/cipsi.irp.f | 1 + src/cipsi/stochastic_cipsi.irp.f | 1 + 2 files changed, 2 insertions(+) diff --git a/src/cipsi/cipsi.irp.f b/src/cipsi/cipsi.irp.f index 7e292d6e..ba922c49 100644 --- a/src/cipsi/cipsi.irp.f +++ b/src/cipsi/cipsi.irp.f @@ -13,6 +13,7 @@ subroutine run_cipsi rss = memory_of_double(N_states)*4.d0 call check_mem(rss,irp_here) + N_iter = 1 allocate (pt2(N_states), zeros(N_states), rpt2(N_states), norm(N_states), variance(N_states)) double precision :: hf_energy_ref diff --git a/src/cipsi/stochastic_cipsi.irp.f b/src/cipsi/stochastic_cipsi.irp.f index ae2b7519..4f968ef7 100644 --- a/src/cipsi/stochastic_cipsi.irp.f +++ b/src/cipsi/stochastic_cipsi.irp.f @@ -12,6 +12,7 @@ subroutine run_stochastic_cipsi double precision, external :: memory_of_double PROVIDE H_apply_buffer_allocated N_generators_bitmask + N_iter = 1 threshold_generators = 1.d0 SOFT_TOUCH threshold_generators From d742bdd655a28648652dc9ba45ea96248a32ce11 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 28 Jun 2019 00:06:51 +0200 Subject: [PATCH 18/59] Cleaning --- src/casscf/test_two_rdm.irp.f | 30 ------------------------------ src/two_body_rdm/two_rdm.irp.f | 26 -------------------------- 2 files changed, 56 deletions(-) delete mode 100644 src/casscf/test_two_rdm.irp.f diff --git a/src/casscf/test_two_rdm.irp.f b/src/casscf/test_two_rdm.irp.f deleted file mode 100644 index 9abe0aa0..00000000 --- a/src/casscf/test_two_rdm.irp.f +++ /dev/null @@ -1,30 +0,0 @@ -program print_two_rdm - implicit none - integer :: i,j,k,l - read_wf = .True. - TOUCH read_wf - - double precision, parameter :: thr = 1.d-15 - - double precision :: accu,twodm - accu = 0.d0 - do i=1,n_act_orb - do j=1,n_act_orb - do k=1,n_act_orb - do l=1,n_act_orb - twodm = coussin_peter_two_rdm_mo(list_act(i),list_act(j),list_act(k),list_act(l)) - if(dabs(twodm - P0tuvx(i,j,k,l)).gt.thr)then - print*,'' - print*,'sum' - write(*,'(3X,4(I2,X),3(F16.13,X))'), i, j, k, l, twodm,P0tuvx(i,j,k,l),dabs(twodm - P0tuvx(i,j,k,l)) - print*,'' - endif - accu += dabs(twodm - P0tuvx(i,j,k,l)) - enddo - enddo - enddo - enddo - print*,'accu = ',accu - print*,' ',accu / dble(mo_num**4) - -end diff --git a/src/two_body_rdm/two_rdm.irp.f b/src/two_body_rdm/two_rdm.irp.f index a75a92cc..89eecdcc 100644 --- a/src/two_body_rdm/two_rdm.irp.f +++ b/src/two_body_rdm/two_rdm.irp.f @@ -1,29 +1,3 @@ -BEGIN_PROVIDER [double precision, coussin_peter_two_rdm_mo, (mo_num,mo_num,mo_num,mo_num)] - implicit none - BEGIN_DOC - ! coussin_peter_two_rdm_mo(i,j,k,l) = the two rdm that peter wants for his CASSCF - END_DOC - integer :: i,j,k,l, istate - coussin_peter_two_rdm_mo = 0.d0 - do istate=1,N_states - do l = 1, mo_num - do k = 1, mo_num - do j = 1, mo_num - do i = 1, mo_num - coussin_peter_two_rdm_mo(i,j,k,l) = & - state_average_weight(istate) * & - ( two_rdm_alpha_beta_mo(i,j,k,l,istate) + & - two_rdm_alpha_alpha_mo(i,j,k,l,istate)+ & - two_rdm_beta_beta_mo(i,j,k,l,istate) ) - enddo - enddo - enddo - enddo - enddo - -END_PROVIDER - - BEGIN_PROVIDER [double precision, two_rdm_alpha_beta_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] &BEGIN_PROVIDER [double precision, two_rdm_alpha_alpha_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] &BEGIN_PROVIDER [double precision, two_rdm_beta_beta_mo, (mo_num,mo_num,mo_num,mo_num,N_states)] From e9724fa8c74662b4d39335e6c4b185f7d04bbaf4 Mon Sep 17 00:00:00 2001 From: eginer Date: Fri, 28 Jun 2019 15:17:04 +0200 Subject: [PATCH 19/59] beginning to work on general routine for 2rdm --- src/two_body_rdm/general_2rdm_routines.irp.f | 488 ++++++++++++++++++ src/two_body_rdm/orb_range_2_rdm.irp.f | 61 +++ .../routines_compute_2rdm_orb_range.irp.f | 430 +++++++++++++++ 3 files changed, 979 insertions(+) create mode 100644 src/two_body_rdm/general_2rdm_routines.irp.f create mode 100644 src/two_body_rdm/orb_range_2_rdm.irp.f create mode 100644 src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f diff --git a/src/two_body_rdm/general_2rdm_routines.irp.f b/src/two_body_rdm/general_2rdm_routines.irp.f new file mode 100644 index 00000000..a9fcd61a --- /dev/null +++ b/src/two_body_rdm/general_2rdm_routines.irp.f @@ -0,0 +1,488 @@ +subroutine orb_range_two_rdm_dm_nstates_openmp(big_array,dim1,norb,list_orb,state_weights,ispin,u_0,N_st,sze) + use bitmasks + implicit none + BEGIN_DOC + ! if ispin == 1 :: alpha/alpha 2rdm + ! == 2 :: beta /beta 2rdm + ! == 3 :: alpha/beta 2rdm + ! == 4 :: spin traced 2rdm :: aa + bb + 0.5 (ab + ba)) + ! + ! Assumes that the determinants are in psi_det + ! + ! istart, iend, ishift, istep are used in ZMQ parallelization. + END_DOC + integer, intent(in) :: N_st,sze + integer, intent(in) :: dim1,norb,list_orb(norb),ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + double precision, intent(in) :: u_0(sze,N_st),state_weights(N_st) + + integer :: k + double precision, allocatable :: u_t(:,:) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t + allocate(u_t(N_st,N_det)) + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det) + enddo + call dtranspose( & + u_0, & + size(u_0, 1), & + u_t, & + size(u_t, 1), & + N_det, N_st) + + call orb_range_two_rdm_dm_nstates_openmp_work(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,1,N_det,0,1) + deallocate(u_t) + + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det) + enddo + +end + +subroutine orb_range_two_rdm_dm_nstates_openmp_work(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + BEGIN_DOC + ! Computes two-rdm + ! + ! Default should be 1,N_det,0,1 + END_DOC + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + integer, intent(in) :: dim1,norb,list_orb(norb),ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + double precision, intent(in) :: u_t(N_st,N_det),state_weights(N_st) + + + PROVIDE N_int + + select case (N_int) + case (1) + call orb_range_two_rdm_dm_nstates_openmp_work_1(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + case (2) + call orb_range_two_rdm_dm_nstates_openmp_work_2(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + case (3) + call orb_range_two_rdm_dm_nstates_openmp_work_3(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + case (4) + call orb_range_two_rdm_dm_nstates_openmp_work_4(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + case default + call orb_range_two_rdm_dm_nstates_openmp_work_N_int(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + end select +end + + + + + BEGIN_TEMPLATE +subroutine orb_range_two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + BEGIN_DOC + ! Computes the two rdm for the N_st vectors |u_t> + ! if ispin == 1 :: alpha/alpha 2rdm + ! == 2 :: beta /beta 2rdm + ! == 3 :: alpha/beta 2rdm + ! == 4 :: spin traced 2rdm :: aa + bb + 0.5 (ab + ba)) + ! The 2rdm will be computed only on the list of orbitals list_orb, which contains norb + ! In any cases, the state average weights will be used with an array state_weights + ! Default should be 1,N_det,0,1 for istart,iend,ishift,istep + END_DOC + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + double precision, intent(in) :: u_t(N_st,N_det),state_weights(N_st) + integer, intent(in) :: dim1,norb,list_orb(norb),ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + + integer :: i,j,k,l + integer :: k_a, k_b, l_a, l_b, m_a, m_b + integer :: istate + integer :: krow, kcol, krow_b, kcol_b + integer :: lrow, lcol + integer :: mrow, mcol + integer(bit_kind) :: spindet($N_int) + integer(bit_kind) :: tmp_det($N_int,2) + integer(bit_kind) :: tmp_det2($N_int,2) + integer(bit_kind) :: tmp_det3($N_int,2) + integer(bit_kind), allocatable :: buffer(:,:) + integer :: n_doubles + integer, allocatable :: doubles(:) + integer, allocatable :: singles_a(:) + integer, allocatable :: singles_b(:) + integer, allocatable :: idx(:), idx0(:) + integer :: maxab, n_singles_a, n_singles_b, kcol_prev + integer*8 :: k8 + double precision :: c_average + + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + else + print*,'Wrong parameter for ispin in general_two_rdm_dm_nstates_openmp_work' + print*,'ispin = ',ispin + stop + endif + + + maxab = max(N_det_alpha_unique, N_det_beta_unique)+1 + allocate(idx0(maxab)) + + do i=1,maxab + idx0(i) = i + enddo + + ! Prepare the array of all alpha single excitations + ! ------------------------------------------------- + + PROVIDE N_int nthreads_davidson + !!$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) & + ! !$OMP SHARED(psi_bilinear_matrix_rows, N_det, & + ! !$OMP psi_bilinear_matrix_columns, & + ! !$OMP psi_det_alpha_unique, psi_det_beta_unique,& + ! !$OMP n_det_alpha_unique, n_det_beta_unique, N_int,& + ! !$OMP psi_bilinear_matrix_transp_rows, & + ! !$OMP psi_bilinear_matrix_transp_columns, & + ! !$OMP psi_bilinear_matrix_transp_order, N_st, & + ! !$OMP psi_bilinear_matrix_order_transp_reverse, & + ! !$OMP psi_bilinear_matrix_columns_loc, & + ! !$OMP psi_bilinear_matrix_transp_rows_loc, & + ! !$OMP istart, iend, istep, irp_here, v_t, s_t, & + ! !$OMP ishift, idx0, u_t, maxab) & + ! !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,& + ! !$OMP lcol, lrow, l_a, l_b, & + ! !$OMP buffer, doubles, n_doubles, & + ! !$OMP tmp_det2, idx, l, kcol_prev, & + ! !$OMP singles_a, n_singles_a, singles_b, & + ! !$OMP n_singles_b, k8) + + ! Alpha/Beta double excitations + ! ============================= + + allocate( buffer($N_int,maxab), & + singles_a(maxab), & + singles_b(maxab), & + doubles(maxab), & + idx(maxab)) + + kcol_prev=-1 + + ASSERT (iend <= N_det) + ASSERT (istart > 0) + ASSERT (istep > 0) + + !!$OMP DO SCHEDULE(dynamic,64) + do k_a=istart+ishift,iend,istep + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + if (kcol /= kcol_prev) then + call get_all_spin_singles_$N_int( & + psi_det_beta_unique, idx0, & + tmp_det(1,2), N_det_beta_unique, & + singles_b, n_singles_b) + endif + kcol_prev = kcol + + ! Loop over singly excited beta columns + ! ------------------------------------- + + do i=1,n_singles_b + lcol = singles_b(i) + + tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol) + + l_a = psi_bilinear_matrix_columns_loc(lcol) + ASSERT (l_a <= N_det) + + do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow) + + ASSERT (l_a <= N_det) + idx(j) = l_a + l_a = l_a+1 + enddo + j = j-1 + + call get_all_spin_singles_$N_int( & + buffer, idx, tmp_det(1,1), j, & + singles_a, n_singles_a ) + + ! Loop over alpha singles + ! ----------------------- + + if(alpha_beta.or.spin_trace)then + do k = 1,n_singles_a + l_a = singles_a(k) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) + c_average = 0.d0 + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + c_average += c_1(l) * c_2(l) * state_weights(l) + enddo + call orb_range_off_diagonal_double_to_two_rdm_ab_dm(tmp_det,tmp_det2,c_average,big_array,dim1,norb,list_orb,ispin) + enddo + endif + + enddo + + enddo + ! !$OMP END DO + + ! !$OMP DO SCHEDULE(dynamic,64) + do k_a=istart+ishift,iend,istep + + + ! Single and double alpha exitations + ! =================================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + ! Initial determinant is at k_b in beta-major representation + ! ---------------------------------------------------------------------- + + k_b = psi_bilinear_matrix_order_transp_reverse(k_a) + ASSERT (k_b <= N_det) + + spindet(1:$N_int) = tmp_det(1:$N_int,1) + + ! Loop inside the beta column to gather all the connected alphas + lcol = psi_bilinear_matrix_columns(k_a) + l_a = psi_bilinear_matrix_columns_loc(lcol) + do i=1,N_det_alpha_unique + if (l_a > N_det) exit + lcol = psi_bilinear_matrix_columns(l_a) + if (lcol /= kcol) exit + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow) + idx(i) = l_a + l_a = l_a+1 + enddo + i = i-1 + + call get_all_spin_singles_and_doubles_$N_int( & + buffer, idx, spindet, i, & + singles_a, doubles, n_singles_a, n_doubles ) + + ! Compute Hij for all alpha singles + ! ---------------------------------- + + tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + do i=1,n_singles_a + l_a = singles_a(i) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) + c_average = 0.d0 + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + c_average += c_1(l) * c_2(l) * state_weights(l) + enddo + if(alpha_beta.or.spin_trace.or.alpha_alpha)then + ! increment the alpha/beta part for single excitations + call orb_range_off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_average,big_array,dim1,norb,list_orb,ispin) + ! increment the alpha/alpha part for single excitations + call orb_range_off_diagonal_single_to_two_rdm_aa_dm(tmp_det,tmp_det2,c_average,big_array,dim1,norb,list_orb,ispin) + endif + + enddo + + + ! Compute Hij for all alpha doubles + ! ---------------------------------- + + if(alpha_alpha.or.spin_trace)then + do i=1,n_doubles + l_a = doubles(i) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + c_average = 0.d0 + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + c_average += c_1(l) * c_2(l) * state_weights(l) + enddo + call orb_range_off_diagonal_double_to_two_rdm_aa_dm(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_average,big_array,dim1,norb,list_orb,ispin) + enddo + endif + + + ! Single and double beta excitations + ! ================================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + kcol = psi_bilinear_matrix_columns(k_a) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + spindet(1:$N_int) = tmp_det(1:$N_int,2) + + ! Initial determinant is at k_b in beta-major representation + ! ----------------------------------------------------------------------- + + k_b = psi_bilinear_matrix_order_transp_reverse(k_a) + ASSERT (k_b <= N_det) + + ! Loop inside the alpha row to gather all the connected betas + lrow = psi_bilinear_matrix_transp_rows(k_b) + l_b = psi_bilinear_matrix_transp_rows_loc(lrow) + do i=1,N_det_beta_unique + if (l_b > N_det) exit + lrow = psi_bilinear_matrix_transp_rows(l_b) + if (lrow /= krow) exit + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol) + idx(i) = l_b + l_b = l_b+1 + enddo + i = i-1 + + call get_all_spin_singles_and_doubles_$N_int( & + buffer, idx, spindet, i, & + singles_b, doubles, n_singles_b, n_doubles ) + + ! Compute Hij for all beta singles + ! ---------------------------------- + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + do i=1,n_singles_b + l_b = singles_b(i) + ASSERT (l_b <= N_det) + + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol) + l_a = psi_bilinear_matrix_transp_order(l_b) + c_average = 0.d0 + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + c_average += c_1(l) * c_2(l) * state_weights(l) + enddo + if(alpha_beta.or.spin_trace.or.beta_beta)then + ! increment the alpha/beta part for single excitations + call orb_range_off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_average,big_array,dim1,norb,list_orb,ispin) + ! increment the beta /beta part for single excitations + call orb_range_off_diagonal_single_to_two_rdm_bb_dm(tmp_det, tmp_det2,c_average,big_array,dim1,norb,list_orb,ispin) + endif + enddo + + ! Compute Hij for all beta doubles + ! ---------------------------------- + + if(beta_beta.or.spin_trace)then + do i=1,n_doubles + l_b = doubles(i) + ASSERT (l_b <= N_det) + + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + l_a = psi_bilinear_matrix_transp_order(l_b) + c_average = 0.d0 + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + c_average += c_1(l) * c_2(l) * state_weights(l) + enddo + call orb_range_off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_alpha_unique(1, lcol),c_average,big_array,dim1,norb,list_orb,ispin) + ASSERT (l_a <= N_det) + + enddo + endif + + + ! Diagonal contribution + ! ===================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + double precision, external :: diag_wee_mat_elem, diag_S_mat_elem + + double precision :: c_1(N_states),c_2(N_states) + c_average = 0.d0 + do l = 1, N_states + c_1(l) = u_t(l,k_a) + c_average += c_1(l) * c_1(l) * state_weights(l) + enddo + + call orb_range_diagonal_contrib_to_all_two_rdm_dm(tmp_det,c_average,big_array,dim1,norb,list_orb,ispin) + + end do + !!$OMP END DO + deallocate(buffer, singles_a, singles_b, doubles, idx) + !!$OMP END PARALLEL + +end + + SUBST [ N_int ] + + 1;; + 2;; + 3;; + 4;; + N_int;; + + END_TEMPLATE + diff --git a/src/two_body_rdm/orb_range_2_rdm.irp.f b/src/two_body_rdm/orb_range_2_rdm.irp.f new file mode 100644 index 00000000..621f6c4b --- /dev/null +++ b/src/two_body_rdm/orb_range_2_rdm.irp.f @@ -0,0 +1,61 @@ + + + + BEGIN_PROVIDER [double precision, act_two_rdm_alpha_alpha_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + implicit none + double precision, allocatable :: state_weights(:) + allocate(state_weights(N_states)) + state_weights = 1.d0/dble(N_states) + integer :: ispin + ! condition for alpha/beta spin + ispin = 1 + act_two_rdm_alpha_alpha_mo = 0.D0 + call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + + END_PROVIDER + + BEGIN_PROVIDER [double precision, act_two_rdm_beta_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + implicit none + double precision, allocatable :: state_weights(:) + allocate(state_weights(N_states)) + state_weights = 1.d0/dble(N_states) + integer :: ispin + ! condition for alpha/beta spin + ispin = 2 + act_two_rdm_beta_beta_mo = 0.d0 + call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_beta_beta_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + + END_PROVIDER + + BEGIN_PROVIDER [double precision, act_two_rdm_alpha_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + implicit none + double precision, allocatable :: state_weights(:) + allocate(state_weights(N_states)) + state_weights = 1.d0/dble(N_states) + integer :: ispin + ! condition for alpha/beta spin + print*,'' + print*,'' + print*,'' + print*,'providint act_two_rdm_alpha_beta_mo ' + ispin = 3 + print*,'ispin = ',ispin + act_two_rdm_alpha_beta_mo = 0.d0 + call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_alpha_beta_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + + END_PROVIDER + + + BEGIN_PROVIDER [double precision, act_two_rdm_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + implicit none + double precision, allocatable :: state_weights(:) + allocate(state_weights(N_states)) + state_weights = 1.d0/dble(N_states) + integer :: ispin + ! condition for alpha/beta spin + ispin = 4 + act_two_rdm_spin_trace_mo = 0.d0 + call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + + END_PROVIDER + diff --git a/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f b/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f new file mode 100644 index 00000000..d115f1bd --- /dev/null +++ b/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f @@ -0,0 +1,430 @@ + + subroutine orb_range_diagonal_contrib_to_two_rdm_ab_dm(det_1,c_1,big_array,dim1,norb,list_orb) + use bitmasks + BEGIN_DOC +! routine that update the DIAGONAL PART of the alpha/beta two body rdm in a specific range of orbitals +! c_1 is supposed to be a scalar quantity, such as state averaged coef + END_DOC + implicit none + integer, intent(in) :: dim1,norb,list_orb(norb) + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + integer(bit_kind), intent(in) :: det_1(N_int,2) + double precision, intent(in) :: c_1 + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + do i = 1, n_occ_ab(1) + h1 = occ(i,1) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array(h1,h1,h2,h2) += c_1 + enddo + enddo + end + + + subroutine orb_range_diagonal_contrib_to_all_two_rdm_dm(det_1,c_1,big_array,dim1,norb,list_orb,ispin) + use bitmasks + BEGIN_DOC +! routine that update the DIAGONAL PART of ALL THREE two body rdm + END_DOC + implicit none + integer, intent(in) :: dim1,norb,list_orb(norb),ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + integer(bit_kind), intent(in) :: det_1(N_int,2) + double precision, intent(in) :: c_1 + + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + BEGIN_DOC +! no factor 1/2 have to be taken into account as the permutations are already taken into account + END_DOC + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + if(alpha_beta)then + do i = 1, n_occ_ab(1) + h1 = occ(i,1) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array(h1,h1,h2,h2) += c_1 + enddo + enddo + else if (alpha_alpha)then + do i = 1, n_occ_ab(1) + h1 = occ(i,1) + do j = 1, n_occ_ab(1) + h2 = occ(j,1) + big_array(h1,h1,h2,h2) += 0.5d0 * c_1 + big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 + enddo + enddo + else if (beta_beta)then + do i = 1, n_occ_ab(2) + h1 = occ(i,2) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array(h1,h1,h2,h2) += 0.5d0 * c_1 + big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 + enddo + enddo + else if(spin_trace)then + ! 0.5 * (alpha beta + beta alpha) + do i = 1, n_occ_ab(1) + h1 = occ(i,1) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array(h1,h1,h2,h2) += 0.5d0 * (c_1 ) + big_array(h2,h2,h1,h1) += 0.5d0 * (c_1 ) + enddo + enddo + ! alpha alpha + do i = 1, n_occ_ab(1) + h1 = occ(i,1) + do j = 1, n_occ_ab(1) + h2 = occ(j,1) + big_array(h1,h1,h2,h2) += 0.5d0 * c_1 + big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 + enddo + enddo + ! beta beta + do i = 1, n_occ_ab(2) + h1 = occ(i,2) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array(h1,h1,h2,h2) += 0.5d0 * c_1 + big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 + enddo + enddo + endif + end + + + subroutine orb_range_off_diagonal_double_to_two_rdm_ab_dm(det_1,det_2,c_1,big_array,dim1,norb,list_orb,ispin) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the alpha/beta 2RDM only for DOUBLE EXCITATIONS + END_DOC + implicit none + integer, intent(in) :: dim1,norb,list_orb(norb),ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + double precision, intent(in) :: c_1 + integer :: i,j,h1,h2,p1,p2,istate + integer :: exc(0:2,2,2) + double precision :: phase + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + call get_double_excitation(det_1,det_2,exc,phase,N_int) + h1 = exc(1,1,1) + h2 = exc(1,1,2) + p1 = exc(1,2,1) + p2 = exc(1,2,2) + if(alpha_beta)then + big_array(h1,p1,h2,p2) += c_1 * phase + else if(spin_trace)then + big_array(h1,p1,h2,p2) += 0.5d0 * c_1 * phase + big_array(h2,p2,h1,p1) += 0.5d0 * c_1 * phase + endif + end + + subroutine orb_range_off_diagonal_single_to_two_rdm_ab_dm(det_1,det_2,c_1,big_array,dim1,norb,list_orb,ispin) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the alpha/beta 2RDM only for SINGLE EXCITATIONS + END_DOC + implicit none + integer, intent(in) :: dim1,norb,list_orb(norb),ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + double precision, intent(in) :: c_1 + + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate,p1 + integer :: exc(0:2,2,2) + double precision :: phase + + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + call get_single_excitation(det_1,det_2,exc,phase,N_int) + if(alpha_beta)then + if (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + p1 = exc(1,2,1) + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + big_array(h1,p1,h2,h2) += c_1 * phase + enddo + else + ! Mono beta + h1 = exc(1,1,2) + p1 = exc(1,2,2) + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + big_array(h2,h2,h1,p1) += c_1 * phase + enddo + endif + else if(spin_trace)then + if (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + p1 = exc(1,2,1) + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + big_array(h1,p1,h2,h2) += 0.5d0 * c_1 * phase + big_array(h2,h2,h1,p1) += 0.5d0 * c_1 * phase + enddo + else + ! Mono beta + h1 = exc(1,1,2) + p1 = exc(1,2,2) + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + big_array(h1,p1,h2,h2) += 0.5d0 * c_1 * phase + big_array(h2,h2,h1,p1) += 0.5d0 * c_1 * phase + enddo + endif + endif + end + + subroutine orb_range_off_diagonal_single_to_two_rdm_aa_dm(det_1,det_2,c_1,big_array,dim1,norb,list_orb,ispin) + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the alpha/alpha 2RDM only for SINGLE EXCITATIONS + END_DOC + use bitmasks + implicit none + integer, intent(in) :: dim1,norb,list_orb(norb),ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + double precision, intent(in) :: c_1 + + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate,p1 + integer :: exc(0:2,2,2) + double precision :: phase + + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + call get_single_excitation(det_1,det_2,exc,phase,N_int) + if(alpha_alpha.or.spin_trace)then + if (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + p1 = exc(1,2,1) + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + big_array(h1,p1,h2,h2) += 0.5d0 * c_1 * phase + big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase + + big_array(h2,h2,h1,p1) += 0.5d0 * c_1 * phase + big_array(h2,p1,h1,h2) -= 0.5d0 * c_1 * phase + enddo + else + return + endif + endif + end + + subroutine orb_range_off_diagonal_single_to_two_rdm_bb_dm(det_1,det_2,c_1,big_array,dim1,norb,list_orb,ispin) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the beta /beta 2RDM only for SINGLE EXCITATIONS + END_DOC + implicit none + integer, intent(in) :: dim1,norb,list_orb(norb),ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + double precision, intent(in) :: c_1 + + + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate,p1 + integer :: exc(0:2,2,2) + double precision :: phase + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + + + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + call get_single_excitation(det_1,det_2,exc,phase,N_int) + if(beta_beta.or.spin_trace)then + if (exc(0,1,1) == 1) then + return + else + ! Mono beta + h1 = exc(1,1,2) + p1 = exc(1,2,2) + do istate = 1, N_states + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + big_array(h1,p1,h2,h2) += 0.5d0 * c_1 * phase + big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase + + big_array(h2,h2,h1,p1) += 0.5d0 * c_1 * phase + big_array(h2,p1,h1,h2) -= 0.5d0 * c_1 * phase + enddo + enddo + endif + endif + end + + + subroutine orb_range_off_diagonal_double_to_two_rdm_aa_dm(det_1,det_2,c_1,big_array,dim1,norb,list_orb,ispin) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the alpha/alpha 2RDM only for DOUBLE EXCITATIONS + END_DOC + implicit none + integer, intent(in) :: dim1,norb,list_orb(norb),ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) + double precision, intent(in) :: c_1 + + integer :: i,j,h1,h2,p1,p2,istate + integer :: exc(0:2,2) + double precision :: phase + + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) + h1 =exc(1,1) + h2 =exc(2,1) + p1 =exc(1,2) + p2 =exc(2,2) + if(alpha_alpha.or.spin_trace)then + do istate = 1, N_states + big_array(h1,p1,h2,p2) += 0.5d0 * c_1 * phase + big_array(h1,p2,h2,p1) -= 0.5d0 * c_1 * phase + + big_array(h2,p2,h1,p1) += 0.5d0 * c_1 * phase + big_array(h2,p1,h1,p2) -= 0.5d0 * c_1 * phase + enddo + endif + end + + subroutine orb_range_off_diagonal_double_to_two_rdm_bb_dm(det_1,det_2,c_1,big_array,dim1,norb,list_orb,ispin) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the beta /beta 2RDM only for DOUBLE EXCITATIONS + END_DOC + implicit none + + integer, intent(in) :: dim1,norb,list_orb(norb),ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) + double precision, intent(in) :: c_1 + + integer :: i,j,h1,h2,p1,p2,istate + integer :: exc(0:2,2) + double precision :: phase + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + + call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) + h1 =exc(1,1) + h2 =exc(2,1) + p1 =exc(1,2) + p2 =exc(2,2) + if(beta_beta.or.spin_trace)then + big_array(h1,p1,h2,p2) += 0.5d0 * c_1* phase + big_array(h1,p2,h2,p1) -= 0.5d0 * c_1* phase + + big_array(h2,p2,h1,p1) += 0.5d0 * c_1* phase + big_array(h2,p1,h1,p2) -= 0.5d0 * c_1* phase + endif + end + From c90c49b56c100b367067d90edbf226dd784a8cc8 Mon Sep 17 00:00:00 2001 From: eginer Date: Fri, 28 Jun 2019 15:55:32 +0200 Subject: [PATCH 20/59] beginning to do it directly in physicist --- .../routines_compute_2rdm_orb_range.irp.f | 64 +++++++++---------- 1 file changed, 31 insertions(+), 33 deletions(-) diff --git a/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f b/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f index d115f1bd..d918932a 100644 --- a/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f +++ b/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f @@ -18,7 +18,7 @@ h1 = occ(i,1) do j = 1, n_occ_ab(2) h2 = occ(j,2) - big_array(h1,h1,h2,h2) += c_1 + big_array(h1,h2,h1,h2) += c_1 enddo enddo end @@ -61,7 +61,7 @@ h1 = occ(i,1) do j = 1, n_occ_ab(2) h2 = occ(j,2) - big_array(h1,h1,h2,h2) += c_1 + big_array(h1,h2,h1,h2) += c_1 enddo enddo else if (alpha_alpha)then @@ -69,7 +69,7 @@ h1 = occ(i,1) do j = 1, n_occ_ab(1) h2 = occ(j,1) - big_array(h1,h1,h2,h2) += 0.5d0 * c_1 + big_array(h1,h2,h1,h2) += 0.5d0 * c_1 big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 enddo enddo @@ -78,7 +78,7 @@ h1 = occ(i,2) do j = 1, n_occ_ab(2) h2 = occ(j,2) - big_array(h1,h1,h2,h2) += 0.5d0 * c_1 + big_array(h1,h2,h1,h2) += 0.5d0 * c_1 big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 enddo enddo @@ -88,25 +88,23 @@ h1 = occ(i,1) do j = 1, n_occ_ab(2) h2 = occ(j,2) - big_array(h1,h1,h2,h2) += 0.5d0 * (c_1 ) - big_array(h2,h2,h1,h1) += 0.5d0 * (c_1 ) + big_array(h1,h2,h1,h2) += 0.5d0 * (c_1 ) + big_array(h2,h1,h2,h1) += 0.5d0 * (c_1 ) enddo enddo - ! alpha alpha do i = 1, n_occ_ab(1) h1 = occ(i,1) do j = 1, n_occ_ab(1) h2 = occ(j,1) - big_array(h1,h1,h2,h2) += 0.5d0 * c_1 + big_array(h1,h2,h1,h2) += 0.5d0 * c_1 big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 enddo enddo - ! beta beta do i = 1, n_occ_ab(2) h1 = occ(i,2) do j = 1, n_occ_ab(2) h2 = occ(j,2) - big_array(h1,h1,h2,h2) += 0.5d0 * c_1 + big_array(h1,h2,h1,h2) += 0.5d0 * c_1 big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 enddo enddo @@ -147,10 +145,10 @@ p1 = exc(1,2,1) p2 = exc(1,2,2) if(alpha_beta)then - big_array(h1,p1,h2,p2) += c_1 * phase + big_array(h1,h2,p1,p2) += c_1 * phase else if(spin_trace)then - big_array(h1,p1,h2,p2) += 0.5d0 * c_1 * phase - big_array(h2,p2,h1,p1) += 0.5d0 * c_1 * phase + big_array(h1,h2,p1,p2) += 0.5d0 * c_1 * phase + big_array(p1,p2,h1,h2) += 0.5d0 * c_1 * phase endif end @@ -195,7 +193,7 @@ p1 = exc(1,2,1) do i = 1, n_occ_ab(2) h2 = occ(i,2) - big_array(h1,p1,h2,h2) += c_1 * phase + big_array(h1,h2,p1,h2) += c_1 * phase enddo else ! Mono beta @@ -203,7 +201,7 @@ p1 = exc(1,2,2) do i = 1, n_occ_ab(1) h2 = occ(i,1) - big_array(h2,h2,h1,p1) += c_1 * phase + big_array(h2,h1,h2,p1) += c_1 * phase enddo endif else if(spin_trace)then @@ -213,8 +211,8 @@ p1 = exc(1,2,1) do i = 1, n_occ_ab(2) h2 = occ(i,2) - big_array(h1,p1,h2,h2) += 0.5d0 * c_1 * phase - big_array(h2,h2,h1,p1) += 0.5d0 * c_1 * phase + big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase + big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase enddo else ! Mono beta @@ -222,8 +220,8 @@ p1 = exc(1,2,2) do i = 1, n_occ_ab(1) h2 = occ(i,1) - big_array(h1,p1,h2,h2) += 0.5d0 * c_1 * phase - big_array(h2,h2,h1,p1) += 0.5d0 * c_1 * phase + big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase + big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase enddo endif endif @@ -270,11 +268,11 @@ p1 = exc(1,2,1) do i = 1, n_occ_ab(1) h2 = occ(i,1) - big_array(h1,p1,h2,h2) += 0.5d0 * c_1 * phase + big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase - big_array(h2,h2,h1,p1) += 0.5d0 * c_1 * phase - big_array(h2,p1,h1,h2) -= 0.5d0 * c_1 * phase + big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase + big_array(h2,h1,p1,h2) -= 0.5d0 * c_1 * phase enddo else return @@ -327,11 +325,11 @@ do istate = 1, N_states do i = 1, n_occ_ab(2) h2 = occ(i,2) - big_array(h1,p1,h2,h2) += 0.5d0 * c_1 * phase + big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase - big_array(h2,h2,h1,p1) += 0.5d0 * c_1 * phase - big_array(h2,p1,h1,h2) -= 0.5d0 * c_1 * phase + big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase + big_array(h2,h1,p1,h2) -= 0.5d0 * c_1 * phase enddo enddo endif @@ -375,11 +373,11 @@ p2 =exc(2,2) if(alpha_alpha.or.spin_trace)then do istate = 1, N_states - big_array(h1,p1,h2,p2) += 0.5d0 * c_1 * phase - big_array(h1,p2,h2,p1) -= 0.5d0 * c_1 * phase + big_array(h1,h2,p1,p2) += 0.5d0 * c_1 * phase + big_array(h1,h2,p2,p1) -= 0.5d0 * c_1 * phase - big_array(h2,p2,h1,p1) += 0.5d0 * c_1 * phase - big_array(h2,p1,h1,p2) -= 0.5d0 * c_1 * phase + big_array(h2,h1,p2,p1) += 0.5d0 * c_1 * phase + big_array(h2,h1,p1,p2) -= 0.5d0 * c_1 * phase enddo endif end @@ -420,11 +418,11 @@ p1 =exc(1,2) p2 =exc(2,2) if(beta_beta.or.spin_trace)then - big_array(h1,p1,h2,p2) += 0.5d0 * c_1* phase - big_array(h1,p2,h2,p1) -= 0.5d0 * c_1* phase + big_array(h1,h2,p1,p2) += 0.5d0 * c_1* phase + big_array(h1,h2,p2,p1) -= 0.5d0 * c_1* phase - big_array(h2,p2,h1,p1) += 0.5d0 * c_1* phase - big_array(h2,p1,h1,p2) -= 0.5d0 * c_1* phase + big_array(h2,h1,p2,p1) += 0.5d0 * c_1* phase + big_array(h2,h1,p1,p2) -= 0.5d0 * c_1* phase endif end From de7e1f70950bebaa8315aa2c12046ef4814a4478 Mon Sep 17 00:00:00 2001 From: eginer Date: Fri, 28 Jun 2019 16:51:16 +0200 Subject: [PATCH 21/59] added test for energy --- src/casscf/get_energy.irp.f | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) create mode 100644 src/casscf/get_energy.irp.f diff --git a/src/casscf/get_energy.irp.f b/src/casscf/get_energy.irp.f new file mode 100644 index 00000000..a7b53f13 --- /dev/null +++ b/src/casscf/get_energy.irp.f @@ -0,0 +1,21 @@ +program print_2rdm + implicit none + read_wf = .True. + touch read_wf + integer :: i,j,k,l + double precision :: accu(4),twodm,thr,act_twodm2,integral,get_two_e_integral + thr = 1.d-10 + + accu = 0.d0 + do l = 1, mo_num + do k = 1, mo_num + do j = 1, mo_num + do i = 1, mo_num + integral = get_two_e_integral(i,j,k,l,mo_integrals_map) + accu(1) += act_two_rdm_spin_trace_mo(i,j,k,l) * integral + enddo + enddo + enddo + enddo + print*,'accu = ',accu(1) +end From 78fe995f55360da3130ed1a1cba9ac0793e0276a Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Fri, 28 Jun 2019 20:45:07 +0200 Subject: [PATCH 22/59] getting there with active orbitals --- src/bitmask/bitmasks_routines.irp.f | 33 ++- src/casscf/get_energy.irp.f | 31 ++- src/two_body_rdm/general_2rdm_routines.irp.f | 42 ++-- src/two_body_rdm/orb_range_2_rdm.irp.f | 10 +- .../routines_compute_2rdm_orb_range.irp.f | 189 +++++++++++++++--- 5 files changed, 248 insertions(+), 57 deletions(-) diff --git a/src/bitmask/bitmasks_routines.irp.f b/src/bitmask/bitmasks_routines.irp.f index 378a3dcd..5c4bf347 100644 --- a/src/bitmask/bitmasks_routines.irp.f +++ b/src/bitmask/bitmasks_routines.irp.f @@ -33,7 +33,7 @@ subroutine bitstring_to_list( string, list, n_elements, Nint) use bitmasks implicit none BEGIN_DOC - ! Gives the inidices(+1) of the bits set to 1 in the bit string + ! Gives the indices(+1) of the bits set to 1 in the bit string END_DOC integer, intent(in) :: Nint integer(bit_kind), intent(in) :: string(Nint) @@ -213,3 +213,34 @@ subroutine print_spindet(string,Nint) print *, trim(output(1)) end + +logical function is_integer_in_string(bite,string,Nint) + use bitmasks + implicit none + integer, intent(in) :: bite,Nint + integer(bit_kind), intent(in) :: string(Nint) + integer(bit_kind) :: string_bite(Nint) + integer :: i,itot,itot_and + character*(2048) :: output(1) + string_bite = 0_bit_kind + call set_bit_to_integer(bite,string_bite,Nint) + itot = 0 + itot_and = 0 + is_integer_in_string = .False. +!print*,'' +!print*,'' +!print*,'bite = ',bite +!call bitstring_to_str( output(1), string_bite, Nint ) +! print *, trim(output(1)) +!call bitstring_to_str( output(1), string, Nint ) +! print *, trim(output(1)) + do i = 1, Nint + itot += popcnt(string(i)) + itot_and += popcnt(ior(string(i),string_bite(i))) + enddo +!print*,'itot,itot_and',itot,itot_and + if(itot == itot_and)then + is_integer_in_string = .True. + endif +!pause +end diff --git a/src/casscf/get_energy.irp.f b/src/casscf/get_energy.irp.f index a7b53f13..29a12cad 100644 --- a/src/casscf/get_energy.irp.f +++ b/src/casscf/get_energy.irp.f @@ -2,20 +2,39 @@ program print_2rdm implicit none read_wf = .True. touch read_wf + call routine +end + +subroutine routine integer :: i,j,k,l + integer :: ii,jj,kk,ll double precision :: accu(4),twodm,thr,act_twodm2,integral,get_two_e_integral thr = 1.d-10 + accu = 0.d0 - do l = 1, mo_num - do k = 1, mo_num - do j = 1, mo_num - do i = 1, mo_num + do ll = 1, n_act_orb + l = list_act(ll) + do kk = 1, n_act_orb + k = list_act(kk) + do jj = 1, n_act_orb + j = list_act(jj) + do ii = 1, n_act_orb + i = list_act(ii) integral = get_two_e_integral(i,j,k,l,mo_integrals_map) - accu(1) += act_two_rdm_spin_trace_mo(i,j,k,l) * integral + accu(1) += act_two_rdm_spin_trace_mo(ii,jj,kk,ll) * integral + !if(dabs(act_two_rdm_spin_trace_mo(ii,jj,kk,ll)).gt.thr)then + !print*,'',ii,jj,kk,ll,act_two_rdm_spin_trace_mo(ii,jj,kk,ll)*integral + !print*,'accu',accu(1) + !endif enddo enddo enddo enddo - print*,'accu = ',accu(1) + print*,'accu = ',accu(1) + print*,'psi_energy_two_e = ',psi_energy_two_e +!double precision :: hij +!call i_H_j_double_alpha_beta(psi_det(1,1,1),psi_det(1,1,2),N_int,hij) +!print*,'hij * 2',hij * psi_coef(1,1) * psi_coef(2,1) * 2.d0 +!print*,'psi diag = ',psi_energy_two_e - hij * psi_coef(1,1) * psi_coef(2,1) * 2.d0 end diff --git a/src/two_body_rdm/general_2rdm_routines.irp.f b/src/two_body_rdm/general_2rdm_routines.irp.f index a9fcd61a..0157c46b 100644 --- a/src/two_body_rdm/general_2rdm_routines.irp.f +++ b/src/two_body_rdm/general_2rdm_routines.irp.f @@ -1,4 +1,4 @@ -subroutine orb_range_two_rdm_dm_nstates_openmp(big_array,dim1,norb,list_orb,state_weights,ispin,u_0,N_st,sze) +subroutine orb_range_two_rdm_dm_nstates_openmp(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_0,N_st,sze) use bitmasks implicit none BEGIN_DOC @@ -13,6 +13,7 @@ subroutine orb_range_two_rdm_dm_nstates_openmp(big_array,dim1,norb,list_orb,stat END_DOC integer, intent(in) :: N_st,sze integer, intent(in) :: dim1,norb,list_orb(norb),ispin + integer, intent(in) :: list_orb_reverse(mo_num) double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) double precision, intent(in) :: u_0(sze,N_st),state_weights(N_st) @@ -30,7 +31,7 @@ subroutine orb_range_two_rdm_dm_nstates_openmp(big_array,dim1,norb,list_orb,stat size(u_t, 1), & N_det, N_st) - call orb_range_two_rdm_dm_nstates_openmp_work(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,1,N_det,0,1) + call orb_range_two_rdm_dm_nstates_openmp_work(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,1,N_det,0,1) deallocate(u_t) do k=1,N_st @@ -39,7 +40,7 @@ subroutine orb_range_two_rdm_dm_nstates_openmp(big_array,dim1,norb,list_orb,stat end -subroutine orb_range_two_rdm_dm_nstates_openmp_work(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) +subroutine orb_range_two_rdm_dm_nstates_openmp_work(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) use bitmasks implicit none BEGIN_DOC @@ -49,23 +50,25 @@ subroutine orb_range_two_rdm_dm_nstates_openmp_work(big_array,dim1,norb,list_orb END_DOC integer, intent(in) :: N_st,sze,istart,iend,ishift,istep integer, intent(in) :: dim1,norb,list_orb(norb),ispin + integer, intent(in) :: list_orb_reverse(mo_num) double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) double precision, intent(in) :: u_t(N_st,N_det),state_weights(N_st) + integer :: k PROVIDE N_int select case (N_int) case (1) - call orb_range_two_rdm_dm_nstates_openmp_work_1(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_two_rdm_dm_nstates_openmp_work_1(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) case (2) - call orb_range_two_rdm_dm_nstates_openmp_work_2(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_two_rdm_dm_nstates_openmp_work_2(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) case (3) - call orb_range_two_rdm_dm_nstates_openmp_work_3(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_two_rdm_dm_nstates_openmp_work_3(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) case (4) - call orb_range_two_rdm_dm_nstates_openmp_work_4(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_two_rdm_dm_nstates_openmp_work_4(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) case default - call orb_range_two_rdm_dm_nstates_openmp_work_N_int(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_two_rdm_dm_nstates_openmp_work_N_int(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) end select end @@ -73,7 +76,7 @@ end BEGIN_TEMPLATE -subroutine orb_range_two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) +subroutine orb_range_two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) use bitmasks implicit none BEGIN_DOC @@ -89,6 +92,7 @@ subroutine orb_range_two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,norb,l integer, intent(in) :: N_st,sze,istart,iend,ishift,istep double precision, intent(in) :: u_t(N_st,N_det),state_weights(N_st) integer, intent(in) :: dim1,norb,list_orb(norb),ispin + integer, intent(in) :: list_orb_reverse(mo_num) double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) integer :: i,j,k,l @@ -112,6 +116,7 @@ subroutine orb_range_two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,norb,l double precision :: c_average logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + integer(bit_kind) :: orb_bitmask($N_int) alpha_alpha = .False. beta_beta = .False. alpha_beta = .False. @@ -129,7 +134,10 @@ subroutine orb_range_two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,norb,l print*,'ispin = ',ispin stop endif + + PROVIDE N_int + call list_to_bitstring( orb_bitmask, list_orb, norb, N_int) maxab = max(N_det_alpha_unique, N_det_beta_unique)+1 allocate(idx0(maxab)) @@ -242,7 +250,7 @@ subroutine orb_range_two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,norb,l c_2(l) = u_t(l,k_a) c_average += c_1(l) * c_2(l) * state_weights(l) enddo - call orb_range_off_diagonal_double_to_two_rdm_ab_dm(tmp_det,tmp_det2,c_average,big_array,dim1,norb,list_orb,ispin) + call orb_range_off_diagonal_double_to_two_rdm_ab_dm(tmp_det,tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) enddo endif @@ -319,9 +327,9 @@ subroutine orb_range_two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,norb,l enddo if(alpha_beta.or.spin_trace.or.alpha_alpha)then ! increment the alpha/beta part for single excitations - call orb_range_off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_average,big_array,dim1,norb,list_orb,ispin) + call orb_range_off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) ! increment the alpha/alpha part for single excitations - call orb_range_off_diagonal_single_to_two_rdm_aa_dm(tmp_det,tmp_det2,c_average,big_array,dim1,norb,list_orb,ispin) + call orb_range_off_diagonal_single_to_two_rdm_aa_dm(tmp_det,tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) endif enddo @@ -344,7 +352,7 @@ subroutine orb_range_two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,norb,l c_2(l) = u_t(l,k_a) c_average += c_1(l) * c_2(l) * state_weights(l) enddo - call orb_range_off_diagonal_double_to_two_rdm_aa_dm(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_average,big_array,dim1,norb,list_orb,ispin) + call orb_range_off_diagonal_double_to_two_rdm_aa_dm(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) enddo endif @@ -411,9 +419,9 @@ subroutine orb_range_two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,norb,l enddo if(alpha_beta.or.spin_trace.or.beta_beta)then ! increment the alpha/beta part for single excitations - call orb_range_off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_average,big_array,dim1,norb,list_orb,ispin) + call orb_range_off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) ! increment the beta /beta part for single excitations - call orb_range_off_diagonal_single_to_two_rdm_bb_dm(tmp_det, tmp_det2,c_average,big_array,dim1,norb,list_orb,ispin) + call orb_range_off_diagonal_single_to_two_rdm_bb_dm(tmp_det, tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) endif enddo @@ -435,7 +443,7 @@ subroutine orb_range_two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,norb,l c_2(l) = u_t(l,k_a) c_average += c_1(l) * c_2(l) * state_weights(l) enddo - call orb_range_off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_alpha_unique(1, lcol),c_average,big_array,dim1,norb,list_orb,ispin) + call orb_range_off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_alpha_unique(1, lcol),c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) ASSERT (l_a <= N_det) enddo @@ -467,7 +475,7 @@ subroutine orb_range_two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,norb,l c_average += c_1(l) * c_1(l) * state_weights(l) enddo - call orb_range_diagonal_contrib_to_all_two_rdm_dm(tmp_det,c_average,big_array,dim1,norb,list_orb,ispin) + call orb_range_diagonal_contrib_to_all_two_rdm_dm(tmp_det,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) end do !!$OMP END DO diff --git a/src/two_body_rdm/orb_range_2_rdm.irp.f b/src/two_body_rdm/orb_range_2_rdm.irp.f index 621f6c4b..e98612c5 100644 --- a/src/two_body_rdm/orb_range_2_rdm.irp.f +++ b/src/two_body_rdm/orb_range_2_rdm.irp.f @@ -10,7 +10,7 @@ ! condition for alpha/beta spin ispin = 1 act_two_rdm_alpha_alpha_mo = 0.D0 - call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) END_PROVIDER @@ -23,7 +23,7 @@ ! condition for alpha/beta spin ispin = 2 act_two_rdm_beta_beta_mo = 0.d0 - call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_beta_beta_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_beta_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) END_PROVIDER @@ -41,7 +41,7 @@ ispin = 3 print*,'ispin = ',ispin act_two_rdm_alpha_beta_mo = 0.d0 - call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_alpha_beta_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_alpha_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) END_PROVIDER @@ -55,7 +55,9 @@ ! condition for alpha/beta spin ispin = 4 act_two_rdm_spin_trace_mo = 0.d0 - call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + integer :: i + + call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) END_PROVIDER diff --git a/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f b/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f index d918932a..c2283fb2 100644 --- a/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f +++ b/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f @@ -1,14 +1,15 @@ - subroutine orb_range_diagonal_contrib_to_two_rdm_ab_dm(det_1,c_1,big_array,dim1,norb,list_orb) + subroutine orb_range_diagonal_contrib_to_two_rdm_ab_dm(det_1,c_1,big_array,dim1,orb_bitmask) use bitmasks BEGIN_DOC ! routine that update the DIAGONAL PART of the alpha/beta two body rdm in a specific range of orbitals ! c_1 is supposed to be a scalar quantity, such as state averaged coef END_DOC implicit none - integer, intent(in) :: dim1,norb,list_orb(norb) + integer, intent(in) :: dim1 double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) integer(bit_kind), intent(in) :: det_1(N_int,2) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) double precision, intent(in) :: c_1 integer :: occ(N_int*bit_kind_size,2) integer :: n_occ_ab(2) @@ -24,21 +25,32 @@ end - subroutine orb_range_diagonal_contrib_to_all_two_rdm_dm(det_1,c_1,big_array,dim1,norb,list_orb,ispin) + subroutine orb_range_diagonal_contrib_to_all_two_rdm_dm(det_1,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) use bitmasks BEGIN_DOC ! routine that update the DIAGONAL PART of ALL THREE two body rdm END_DOC implicit none - integer, intent(in) :: dim1,norb,list_orb(norb),ispin + integer, intent(in) :: dim1,ispin + integer, intent(in) :: list_orb_reverse(mo_num) double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) integer(bit_kind), intent(in) :: det_1(N_int,2) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) double precision, intent(in) :: c_1 integer :: occ(N_int*bit_kind_size,2) integer :: n_occ_ab(2) integer :: i,j,h1,h2,istate + integer(bit_kind) :: det_1_act(N_int,2) logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + do i = 1, N_int + det_1_act(i,1) = iand(det_1(i,1),orb_bitmask(i)) + det_1_act(i,2) = iand(det_1(i,2),orb_bitmask(i)) + enddo + +!print*,'ahah' +!call debug_det(det_1_act,N_int) +!pause alpha_alpha = .False. beta_beta = .False. alpha_beta = .False. @@ -55,29 +67,43 @@ BEGIN_DOC ! no factor 1/2 have to be taken into account as the permutations are already taken into account END_DOC - call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + call bitstring_to_list_ab(det_1_act, occ, n_occ_ab, N_int) + logical :: is_integer_in_string + integer :: i1,i2 if(alpha_beta)then do i = 1, n_occ_ab(1) - h1 = occ(i,1) + i1 = occ(i,1) +! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle do j = 1, n_occ_ab(2) - h2 = occ(j,2) +! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle + i2 = occ(j,2) + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) big_array(h1,h2,h1,h2) += c_1 enddo enddo else if (alpha_alpha)then do i = 1, n_occ_ab(1) - h1 = occ(i,1) + i1 = occ(i,1) +! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle do j = 1, n_occ_ab(1) - h2 = occ(j,1) + i2 = occ(j,1) +! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) big_array(h1,h2,h1,h2) += 0.5d0 * c_1 big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 enddo enddo else if (beta_beta)then do i = 1, n_occ_ab(2) - h1 = occ(i,2) + i1 = occ(i,2) +! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle do j = 1, n_occ_ab(2) - h2 = occ(j,2) + i2 = occ(j,2) +! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) big_array(h1,h2,h1,h2) += 0.5d0 * c_1 big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 enddo @@ -85,25 +111,38 @@ else if(spin_trace)then ! 0.5 * (alpha beta + beta alpha) do i = 1, n_occ_ab(1) - h1 = occ(i,1) + i1 = occ(i,1) +! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle do j = 1, n_occ_ab(2) - h2 = occ(j,2) + i2 = occ(j,2) +! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) big_array(h1,h2,h1,h2) += 0.5d0 * (c_1 ) big_array(h2,h1,h2,h1) += 0.5d0 * (c_1 ) enddo enddo + !stop do i = 1, n_occ_ab(1) - h1 = occ(i,1) + i1 = occ(i,1) +! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle do j = 1, n_occ_ab(1) - h2 = occ(j,1) + i2 = occ(j,1) +! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) big_array(h1,h2,h1,h2) += 0.5d0 * c_1 big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 enddo enddo do i = 1, n_occ_ab(2) - h1 = occ(i,2) + i1 = occ(i,2) +! if(.not.is_integer_in_string(i1,orb_bitmask,N_int))cycle do j = 1, n_occ_ab(2) - h2 = occ(j,2) + i2 = occ(j,2) +! if(.not.is_integer_in_string(i2,orb_bitmask,N_int))cycle + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) big_array(h1,h2,h1,h2) += 0.5d0 * c_1 big_array(h1,h2,h2,h1) -= 0.5d0 * c_1 enddo @@ -112,20 +151,23 @@ end - subroutine orb_range_off_diagonal_double_to_two_rdm_ab_dm(det_1,det_2,c_1,big_array,dim1,norb,list_orb,ispin) + subroutine orb_range_off_diagonal_double_to_two_rdm_ab_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) use bitmasks BEGIN_DOC ! routine that update the OFF DIAGONAL PART of the alpha/beta 2RDM only for DOUBLE EXCITATIONS END_DOC implicit none - integer, intent(in) :: dim1,norb,list_orb(norb),ispin + integer, intent(in) :: dim1,ispin double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + integer, intent(in) :: list_orb_reverse(mo_num) double precision, intent(in) :: c_1 integer :: i,j,h1,h2,p1,p2,istate integer :: exc(0:2,2,2) double precision :: phase logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string alpha_alpha = .False. beta_beta = .False. alpha_beta = .False. @@ -139,28 +181,52 @@ else if(ispin == 4)then spin_trace = .True. endif +!print*,'' +!do i = 1, mo_num +! print*,'list_orb',i,list_orb_reverse(i) +!enddo call get_double_excitation(det_1,det_2,exc,phase,N_int) h1 = exc(1,1,1) +!print*,'h1',h1 + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) +!print*,'passed h1 = ',h1 h2 = exc(1,1,2) +!print*,'h2',h2 + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return + h2 = list_orb_reverse(h2) +!print*,'passed h2 = ',h2 p1 = exc(1,2,1) +!print*,'p1',p1 + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) +!print*,'passed p1 = ',p1 p2 = exc(1,2,2) +!print*,'p2',p2 + if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return + p2 = list_orb_reverse(p2) +!print*,'passed p2 = ',p2 if(alpha_beta)then big_array(h1,h2,p1,p2) += c_1 * phase else if(spin_trace)then big_array(h1,h2,p1,p2) += 0.5d0 * c_1 * phase big_array(p1,p2,h1,h2) += 0.5d0 * c_1 * phase + !print*,'h1,h2,p1,p2',h1,h2,p1,p2 + !print*,'',big_array(h1,h2,p1,p2) endif end - subroutine orb_range_off_diagonal_single_to_two_rdm_ab_dm(det_1,det_2,c_1,big_array,dim1,norb,list_orb,ispin) + subroutine orb_range_off_diagonal_single_to_two_rdm_ab_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) use bitmasks BEGIN_DOC ! routine that update the OFF DIAGONAL PART of the alpha/beta 2RDM only for SINGLE EXCITATIONS END_DOC implicit none - integer, intent(in) :: dim1,norb,list_orb(norb),ispin + integer, intent(in) :: dim1,ispin double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + integer, intent(in) :: list_orb_reverse(mo_num) double precision, intent(in) :: c_1 integer :: occ(N_int*bit_kind_size,2) @@ -170,6 +236,7 @@ double precision :: phase logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string alpha_alpha = .False. beta_beta = .False. alpha_beta = .False. @@ -190,17 +257,29 @@ if (exc(0,1,1) == 1) then ! Mono alpha h1 = exc(1,1,1) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) p1 = exc(1,2,1) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) do i = 1, n_occ_ab(2) h2 = occ(i,2) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle + h2 = list_orb_reverse(h2) big_array(h1,h2,p1,h2) += c_1 * phase enddo else ! Mono beta h1 = exc(1,1,2) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) p1 = exc(1,2,2) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) do i = 1, n_occ_ab(1) h2 = occ(i,1) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle + h2 = list_orb_reverse(h2) big_array(h2,h1,h2,p1) += c_1 * phase enddo endif @@ -208,18 +287,30 @@ if (exc(0,1,1) == 1) then ! Mono alpha h1 = exc(1,1,1) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) p1 = exc(1,2,1) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) do i = 1, n_occ_ab(2) h2 = occ(i,2) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle + h2 = list_orb_reverse(h2) big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase enddo else ! Mono beta h1 = exc(1,1,2) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) p1 = exc(1,2,2) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) do i = 1, n_occ_ab(1) h2 = occ(i,1) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle + h2 = list_orb_reverse(h2) big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase enddo @@ -227,15 +318,17 @@ endif end - subroutine orb_range_off_diagonal_single_to_two_rdm_aa_dm(det_1,det_2,c_1,big_array,dim1,norb,list_orb,ispin) + subroutine orb_range_off_diagonal_single_to_two_rdm_aa_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) BEGIN_DOC ! routine that update the OFF DIAGONAL PART of the alpha/alpha 2RDM only for SINGLE EXCITATIONS END_DOC use bitmasks implicit none - integer, intent(in) :: dim1,norb,list_orb(norb),ispin + integer, intent(in) :: dim1,ispin double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + integer, intent(in) :: list_orb_reverse(mo_num) double precision, intent(in) :: c_1 integer :: occ(N_int*bit_kind_size,2) @@ -245,6 +338,7 @@ double precision :: phase logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string alpha_alpha = .False. beta_beta = .False. alpha_beta = .False. @@ -265,9 +359,15 @@ if (exc(0,1,1) == 1) then ! Mono alpha h1 = exc(1,1,1) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) p1 = exc(1,2,1) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) do i = 1, n_occ_ab(1) h2 = occ(i,1) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle + h2 = list_orb_reverse(h2) big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase @@ -280,15 +380,17 @@ endif end - subroutine orb_range_off_diagonal_single_to_two_rdm_bb_dm(det_1,det_2,c_1,big_array,dim1,norb,list_orb,ispin) + subroutine orb_range_off_diagonal_single_to_two_rdm_bb_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) use bitmasks BEGIN_DOC ! routine that update the OFF DIAGONAL PART of the beta /beta 2RDM only for SINGLE EXCITATIONS END_DOC implicit none - integer, intent(in) :: dim1,norb,list_orb(norb),ispin + integer, intent(in) :: dim1,ispin double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + integer, intent(in) :: list_orb_reverse(mo_num) double precision, intent(in) :: c_1 @@ -298,6 +400,7 @@ integer :: exc(0:2,2,2) double precision :: phase logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string alpha_alpha = .False. beta_beta = .False. alpha_beta = .False. @@ -321,10 +424,16 @@ else ! Mono beta h1 = exc(1,1,2) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) p1 = exc(1,2,2) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) do istate = 1, N_states do i = 1, n_occ_ab(2) h2 = occ(i,2) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle + h2 = list_orb_reverse(h2) big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase @@ -337,15 +446,17 @@ end - subroutine orb_range_off_diagonal_double_to_two_rdm_aa_dm(det_1,det_2,c_1,big_array,dim1,norb,list_orb,ispin) + subroutine orb_range_off_diagonal_double_to_two_rdm_aa_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) use bitmasks BEGIN_DOC ! routine that update the OFF DIAGONAL PART of the alpha/alpha 2RDM only for DOUBLE EXCITATIONS END_DOC implicit none - integer, intent(in) :: dim1,norb,list_orb(norb),ispin + integer, intent(in) :: dim1,ispin double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + integer, intent(in) :: list_orb_reverse(mo_num) double precision, intent(in) :: c_1 integer :: i,j,h1,h2,p1,p2,istate @@ -353,6 +464,7 @@ double precision :: phase logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string alpha_alpha = .False. beta_beta = .False. alpha_beta = .False. @@ -368,9 +480,17 @@ endif call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) h1 =exc(1,1) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) h2 =exc(2,1) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return + h2 = list_orb_reverse(h2) p1 =exc(1,2) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) p2 =exc(2,2) + if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return + p2 = list_orb_reverse(p2) if(alpha_alpha.or.spin_trace)then do istate = 1, N_states big_array(h1,h2,p1,p2) += 0.5d0 * c_1 * phase @@ -382,22 +502,25 @@ endif end - subroutine orb_range_off_diagonal_double_to_two_rdm_bb_dm(det_1,det_2,c_1,big_array,dim1,norb,list_orb,ispin) + subroutine orb_range_off_diagonal_double_to_two_rdm_bb_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) use bitmasks BEGIN_DOC ! routine that update the OFF DIAGONAL PART of the beta /beta 2RDM only for DOUBLE EXCITATIONS END_DOC implicit none - integer, intent(in) :: dim1,norb,list_orb(norb),ispin + integer, intent(in) :: dim1,ispin double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + integer, intent(in) :: list_orb_reverse(mo_num) double precision, intent(in) :: c_1 integer :: i,j,h1,h2,p1,p2,istate integer :: exc(0:2,2) double precision :: phase logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string alpha_alpha = .False. beta_beta = .False. alpha_beta = .False. @@ -414,9 +537,17 @@ call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) h1 =exc(1,1) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) h2 =exc(2,1) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return + h2 = list_orb_reverse(h2) p1 =exc(1,2) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) p2 =exc(2,2) + if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return + p2 = list_orb_reverse(p2) if(beta_beta.or.spin_trace)then big_array(h1,h2,p1,p2) += 0.5d0 * c_1* phase big_array(h1,h2,p2,p1) -= 0.5d0 * c_1* phase From 57eabff6758b254d9c6e92b04e356205509ecc1d Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Sat, 29 Jun 2019 17:29:32 +0200 Subject: [PATCH 23/59] added documentation for the two-rdm --- src/casscf/densities.irp.f | 8 +- src/casscf/get_energy.irp.f | 14 +- src/two_body_rdm/ab_only_routines.irp.f | 22 +-- src/two_body_rdm/all_2rdm_routines.irp.f | 2 +- src/two_body_rdm/orb_range_2_rdm.irp.f | 20 +++ ...outines.irp.f => orb_range_routines.irp.f} | 0 src/two_body_rdm/routines_compute_2rdm.irp.f | 14 +- .../routines_compute_2rdm_orb_range.irp.f | 129 +++++++++++++++++- 8 files changed, 168 insertions(+), 41 deletions(-) rename src/two_body_rdm/{general_2rdm_routines.irp.f => orb_range_routines.irp.f} (100%) diff --git a/src/casscf/densities.irp.f b/src/casscf/densities.irp.f index 7b243bb4..30a914f1 100644 --- a/src/casscf/densities.irp.f +++ b/src/casscf/densities.irp.f @@ -42,7 +42,7 @@ BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ] integer(bit_kind), dimension(N_int,2) :: det_mu_ex2, det_mu_ex21, det_mu_ex22 if (bavard) then - write(6,*) ' providing density matrix P0' + write(6,*) ' providing the 2 body RDM on the active part' endif P0tuvx= 0.d0 @@ -55,11 +55,7 @@ BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ] uu = list_act(u) do t = 1, n_act_orb tt = list_act(t) - P0tuvx(t,u,v,x) = & - state_average_weight(istate) * & - ( two_rdm_alpha_beta_mo (tt,uu,vv,xx,istate) + & - two_rdm_alpha_alpha_mo(tt,uu,vv,xx,istate) + & - two_rdm_beta_beta_mo (tt,uu,vv,xx,istate) ) + P0tuvx(t,u,v,x) = act_two_rdm_spin_trace_mo(t,v,u,x) enddo enddo enddo diff --git a/src/casscf/get_energy.irp.f b/src/casscf/get_energy.irp.f index 29a12cad..0a5cfb49 100644 --- a/src/casscf/get_energy.irp.f +++ b/src/casscf/get_energy.irp.f @@ -1,5 +1,10 @@ program print_2rdm implicit none + BEGIN_DOC + ! get the active part of the bielectronic energy on a given wave function. + ! + ! useful to test the active part of the spin trace 2 rdms + END_DOC read_wf = .True. touch read_wf call routine @@ -23,18 +28,9 @@ subroutine routine i = list_act(ii) integral = get_two_e_integral(i,j,k,l,mo_integrals_map) accu(1) += act_two_rdm_spin_trace_mo(ii,jj,kk,ll) * integral - !if(dabs(act_two_rdm_spin_trace_mo(ii,jj,kk,ll)).gt.thr)then - !print*,'',ii,jj,kk,ll,act_two_rdm_spin_trace_mo(ii,jj,kk,ll)*integral - !print*,'accu',accu(1) - !endif enddo enddo enddo enddo print*,'accu = ',accu(1) - print*,'psi_energy_two_e = ',psi_energy_two_e -!double precision :: hij -!call i_H_j_double_alpha_beta(psi_det(1,1,1),psi_det(1,1,2),N_int,hij) -!print*,'hij * 2',hij * psi_coef(1,1) * psi_coef(2,1) * 2.d0 -!print*,'psi diag = ',psi_energy_two_e - hij * psi_coef(1,1) * psi_coef(2,1) * 2.d0 end diff --git a/src/two_body_rdm/ab_only_routines.irp.f b/src/two_body_rdm/ab_only_routines.irp.f index 195f439a..9041c753 100644 --- a/src/two_body_rdm/ab_only_routines.irp.f +++ b/src/two_body_rdm/ab_only_routines.irp.f @@ -1,9 +1,9 @@ - subroutine two_rdm_dm_nstates_openmp(big_array,dim1,dim2,dim3,dim4,u_0,N_st,sze) + subroutine two_rdm_ab_nstates_openmp(big_array,dim1,dim2,dim3,dim4,u_0,N_st,sze) use bitmasks implicit none BEGIN_DOC - ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + ! Computes the alpha/beta part of the two-body density matrix IN CHEMIST NOTATIONS ! ! Assumes that the determinants are in psi_det ! @@ -27,7 +27,7 @@ size(u_t, 1), & N_det, N_st) - call two_rdm_dm_nstates_openmp_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1) + call two_rdm_ab_nstates_openmp_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1) deallocate(u_t) do k=1,N_st @@ -37,11 +37,11 @@ end - subroutine two_rdm_dm_nstates_openmp_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + subroutine two_rdm_ab_nstates_openmp_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) use bitmasks implicit none BEGIN_DOC - ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + ! Computes the alpha/beta part of the two-body density matrix ! ! Default should be 1,N_det,0,1 END_DOC @@ -55,20 +55,20 @@ select case (N_int) case (1) - call two_rdm_dm_nstates_openmp_work_1(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + call two_rdm_ab_nstates_openmp_work_1(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) case (2) - call two_rdm_dm_nstates_openmp_work_2(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + call two_rdm_ab_nstates_openmp_work_2(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) case (3) - call two_rdm_dm_nstates_openmp_work_3(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + call two_rdm_ab_nstates_openmp_work_3(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) case (4) - call two_rdm_dm_nstates_openmp_work_4(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + call two_rdm_ab_nstates_openmp_work_4(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) case default - call two_rdm_dm_nstates_openmp_work_N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + call two_rdm_ab_nstates_openmp_work_N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) end select end BEGIN_TEMPLATE - subroutine two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + subroutine two_rdm_ab_nstates_openmp_work_$N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) use bitmasks implicit none integer, intent(in) :: N_st,sze,istart,iend,ishift,istep diff --git a/src/two_body_rdm/all_2rdm_routines.irp.f b/src/two_body_rdm/all_2rdm_routines.irp.f index 75d71ded..3f08b18f 100644 --- a/src/two_body_rdm/all_2rdm_routines.irp.f +++ b/src/two_body_rdm/all_2rdm_routines.irp.f @@ -2,7 +2,7 @@ subroutine all_two_rdm_dm_nstates_openmp(big_array_aa,big_array_bb,big_array_ab, use bitmasks implicit none BEGIN_DOC - ! Computes v_0 = H|u_0> and s_0 = S^2 |u_0> + ! Computes the alpha/alpha, beta/beta and alpha/beta part of the two-body density matrix IN CHEMIST NOTATIONS ! ! Assumes that the determinants are in psi_det ! diff --git a/src/two_body_rdm/orb_range_2_rdm.irp.f b/src/two_body_rdm/orb_range_2_rdm.irp.f index e98612c5..c40c46d2 100644 --- a/src/two_body_rdm/orb_range_2_rdm.irp.f +++ b/src/two_body_rdm/orb_range_2_rdm.irp.f @@ -4,6 +4,10 @@ BEGIN_PROVIDER [double precision, act_two_rdm_alpha_alpha_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] implicit none double precision, allocatable :: state_weights(:) + BEGIN_DOC +! act_two_rdm_alpha_alpha_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-alpha electron pairs +! = + END_DOC allocate(state_weights(N_states)) state_weights = 1.d0/dble(N_states) integer :: ispin @@ -17,6 +21,10 @@ BEGIN_PROVIDER [double precision, act_two_rdm_beta_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] implicit none double precision, allocatable :: state_weights(:) + BEGIN_DOC +! act_two_rdm_beta_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for beta-beta electron pairs +! = + END_DOC allocate(state_weights(N_states)) state_weights = 1.d0/dble(N_states) integer :: ispin @@ -30,6 +38,10 @@ BEGIN_PROVIDER [double precision, act_two_rdm_alpha_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] implicit none double precision, allocatable :: state_weights(:) + BEGIN_DOC +! act_two_rdm_alpha_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-beta electron pairs +! = + END_DOC allocate(state_weights(N_states)) state_weights = 1.d0/dble(N_states) integer :: ispin @@ -48,6 +60,14 @@ BEGIN_PROVIDER [double precision, act_two_rdm_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] implicit none + BEGIN_DOC +! act_two_rdm_spin_trace_mo(i,j,k,l) = state average physicist spin trace two-body rdm restricted to the ACTIVE indices +! The active part of the two-electron energy can be computed as: +! +! \sum_{i,j,k,l = 1, n_act_orb} act_two_rdm_spin_trace_mo(i,j,k,l) * < ii jj | kk ll > +! +! with ii = list_act(i), jj = list_act(j), kk = list_act(k), ll = list_act(l) + END_DOC double precision, allocatable :: state_weights(:) allocate(state_weights(N_states)) state_weights = 1.d0/dble(N_states) diff --git a/src/two_body_rdm/general_2rdm_routines.irp.f b/src/two_body_rdm/orb_range_routines.irp.f similarity index 100% rename from src/two_body_rdm/general_2rdm_routines.irp.f rename to src/two_body_rdm/orb_range_routines.irp.f diff --git a/src/two_body_rdm/routines_compute_2rdm.irp.f b/src/two_body_rdm/routines_compute_2rdm.irp.f index 7165576f..112d2e36 100644 --- a/src/two_body_rdm/routines_compute_2rdm.irp.f +++ b/src/two_body_rdm/routines_compute_2rdm.irp.f @@ -3,7 +3,7 @@ subroutine diagonal_contrib_to_two_rdm_ab_dm(det_1,c_1,big_array,dim1,dim2,dim3,dim4) use bitmasks BEGIN_DOC -! routine that update the DIAGONAL PART of the alpha/beta two body rdm +! routine that update the DIAGONAL PART of the alpha/beta two body rdm IN CHEMIST NOTATIONS END_DOC implicit none integer, intent(in) :: dim1,dim2,dim3,dim4 @@ -31,7 +31,7 @@ subroutine diagonal_contrib_to_all_two_rdm_dm(det_1,c_1,big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4) use bitmasks BEGIN_DOC -! routine that update the DIAGONAL PART of ALL THREE two body rdm +! routine that update the DIAGONAL PART of ALL THREE two body rdm IN CHEMIST NOTATIONS END_DOC implicit none integer, intent(in) :: dim1,dim2,dim3,dim4 @@ -77,7 +77,7 @@ subroutine off_diagonal_double_to_two_rdm_ab_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) use bitmasks BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the alpha/beta 2RDM only for DOUBLE EXCITATIONS +! routine that update the OFF DIAGONAL PART of the alpha/beta 2RDM only for DOUBLE EXCITATIONS IN CHEMIST NOTATIONS END_DOC implicit none integer, intent(in) :: dim1,dim2,dim3,dim4 @@ -101,7 +101,7 @@ subroutine off_diagonal_single_to_two_rdm_ab_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) use bitmasks BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the alpha/beta 2RDM only for SINGLE EXCITATIONS +! routine that update the OFF DIAGONAL PART of the alpha/beta 2RDM only for SINGLE EXCITATIONS IN CHEMIST NOTATIONS END_DOC implicit none integer, intent(in) :: dim1,dim2,dim3,dim4 @@ -140,7 +140,7 @@ subroutine off_diagonal_single_to_two_rdm_aa_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the alpha/alpha 2RDM only for SINGLE EXCITATIONS +! routine that update the OFF DIAGONAL PART of the alpha/alpha 2RDM only for SINGLE EXCITATIONS IN CHEMIST NOTATIONS END_DOC use bitmasks implicit none @@ -177,7 +177,7 @@ subroutine off_diagonal_single_to_two_rdm_bb_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) use bitmasks BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the beta /beta 2RDM only for SINGLE EXCITATIONS +! routine that update the OFF DIAGONAL PART of the beta /beta 2RDM only for SINGLE EXCITATIONS IN CHEMIST NOTATIONS END_DOC implicit none integer, intent(in) :: dim1,dim2,dim3,dim4 @@ -214,7 +214,7 @@ subroutine off_diagonal_double_to_two_rdm_aa_dm(det_1,det_2,c_1,c_2,big_array,dim1,dim2,dim3,dim4) use bitmasks BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the alpha/alpha 2RDM only for DOUBLE EXCITATIONS +! routine that update the OFF DIAGONAL PART of the alpha/alpha 2RDM only for DOUBLE EXCITATIONS IN CHEMIST NOTATIONS END_DOC implicit none integer, intent(in) :: dim1,dim2,dim3,dim4 diff --git a/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f b/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f index c2283fb2..a3c7a76d 100644 --- a/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f +++ b/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f @@ -28,7 +28,20 @@ subroutine orb_range_diagonal_contrib_to_all_two_rdm_dm(det_1,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) use bitmasks BEGIN_DOC -! routine that update the DIAGONAL PART of ALL THREE two body rdm +! routine that update the DIAGONAL PART of the two body rdms in a specific range of orbitals for a given determinant det_1 +! +! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 +! +! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation +! +! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +! +! ispin determines which spin-spin component of the two-rdm you will update +! +! ispin == 1 :: alpha/ alpha +! ispin == 2 :: beta / beta +! ispin == 3 :: alpha/ beta +! ispin == 4 :: spin traced <=> total two-rdm END_DOC implicit none integer, intent(in) :: dim1,ispin @@ -154,7 +167,24 @@ subroutine orb_range_off_diagonal_double_to_two_rdm_ab_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) use bitmasks BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the alpha/beta 2RDM only for DOUBLE EXCITATIONS +! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for +! +! a given couple of determinant det_1, det_2 being a alpha/beta DOUBLE excitation with respect to one another +! +! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 +! +! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation +! +! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +! +! ispin determines which spin-spin component of the two-rdm you will update +! +! ispin == 1 :: alpha/ alpha +! ispin == 2 :: beta / beta +! ispin == 3 :: alpha/ beta +! ispin == 4 :: spin traced <=> total two-rdm +! +! here, only ispin == 3 or 4 will do something END_DOC implicit none integer, intent(in) :: dim1,ispin @@ -219,7 +249,24 @@ subroutine orb_range_off_diagonal_single_to_two_rdm_ab_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) use bitmasks BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the alpha/beta 2RDM only for SINGLE EXCITATIONS +! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for +! +! a given couple of determinant det_1, det_2 being a SINGLE excitation with respect to one another +! +! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 +! +! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation +! +! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +! +! ispin determines which spin-spin component of the two-rdm you will update +! +! ispin == 1 :: alpha/ alpha +! ispin == 2 :: beta / beta +! ispin == 3 :: alpha/ beta +! ispin == 4 :: spin traced <=> total two-rdm +! +! here, only ispin == 3 or 4 will do something END_DOC implicit none integer, intent(in) :: dim1,ispin @@ -320,7 +367,24 @@ subroutine orb_range_off_diagonal_single_to_two_rdm_aa_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the alpha/alpha 2RDM only for SINGLE EXCITATIONS +! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for +! +! a given couple of determinant det_1, det_2 being a ALPHA SINGLE excitation with respect to one another +! +! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 +! +! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation +! +! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +! +! ispin determines which spin-spin component of the two-rdm you will update +! +! ispin == 1 :: alpha/ alpha +! ispin == 2 :: beta / beta +! ispin == 3 :: alpha/ beta +! ispin == 4 :: spin traced <=> total two-rdm +! +! here, only ispin == 1 or 4 will do something END_DOC use bitmasks implicit none @@ -383,7 +447,24 @@ subroutine orb_range_off_diagonal_single_to_two_rdm_bb_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) use bitmasks BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the beta /beta 2RDM only for SINGLE EXCITATIONS +! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for +! +! a given couple of determinant det_1, det_2 being a BETA SINGLE excitation with respect to one another +! +! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 +! +! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation +! +! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +! +! ispin determines which spin-spin component of the two-rdm you will update +! +! ispin == 1 :: alpha/ alpha +! ispin == 2 :: beta / beta +! ispin == 3 :: alpha/ beta +! ispin == 4 :: spin traced <=> total two-rdm +! +! here, only ispin == 2 or 4 will do something END_DOC implicit none integer, intent(in) :: dim1,ispin @@ -449,7 +530,24 @@ subroutine orb_range_off_diagonal_double_to_two_rdm_aa_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) use bitmasks BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the alpha/alpha 2RDM only for DOUBLE EXCITATIONS +! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for +! +! a given couple of determinant det_1, det_2 being a ALPHA/ALPHA DOUBLE excitation with respect to one another +! +! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 +! +! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation +! +! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +! +! ispin determines which spin-spin component of the two-rdm you will update +! +! ispin == 1 :: alpha/ alpha +! ispin == 2 :: beta / beta +! ispin == 3 :: alpha/ beta +! ispin == 4 :: spin traced <=> total two-rdm +! +! here, only ispin == 1 or 4 will do something END_DOC implicit none integer, intent(in) :: dim1,ispin @@ -505,7 +603,24 @@ subroutine orb_range_off_diagonal_double_to_two_rdm_bb_dm(det_1,det_2,c_1,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) use bitmasks BEGIN_DOC -! routine that update the OFF DIAGONAL PART of the beta /beta 2RDM only for DOUBLE EXCITATIONS +! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for +! +! a given couple of determinant det_1, det_2 being a BETA /BETA DOUBLE excitation with respect to one another +! +! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 +! +! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation +! +! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +! +! ispin determines which spin-spin component of the two-rdm you will update +! +! ispin == 1 :: alpha/ alpha +! ispin == 2 :: beta / beta +! ispin == 3 :: alpha/ beta +! ispin == 4 :: spin traced <=> total two-rdm +! +! here, only ispin == 2 or 4 will do something END_DOC implicit none From 3c9728be99bc54ec98c217936e03861e8652a7c5 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Sat, 29 Jun 2019 17:34:20 +0200 Subject: [PATCH 24/59] comments --- src/casscf/densities.irp.f | 7 ++++--- src/two_body_rdm/README.rst | 2 +- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/casscf/densities.irp.f b/src/casscf/densities.irp.f index 30a914f1..3cfd7583 100644 --- a/src/casscf/densities.irp.f +++ b/src/casscf/densities.irp.f @@ -19,14 +19,15 @@ END_PROVIDER BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ] BEGIN_DOC - ! the second-order density matrix in the basis of the starting MOs - ! matrices are state averaged + ! The second-order density matrix in the basis of the starting MOs ONLY IN THE RANGE OF ACTIVE MOS + ! The values are state averaged ! - ! we use the spin-free generators of mono-excitations + ! We use the spin-free generators of mono-excitations ! E_pq destroys q and creates p ! D_pq = <0|E_pq|0> = D_qp ! P_pqrs = 1/2 <0|E_pq E_rs - delta_qr E_ps|0> ! + ! P0tuvx(p,q,r,s) = chemist notation : 1/2 <0|E_pq E_rs - delta_qr E_ps|0> END_DOC implicit none integer :: t,u,v,x diff --git a/src/two_body_rdm/README.rst b/src/two_body_rdm/README.rst index ea5839e8..978240c9 100644 --- a/src/two_body_rdm/README.rst +++ b/src/two_body_rdm/README.rst @@ -3,6 +3,6 @@ two_body_rdm ============ Contains the two rdms $\alpha\alpha$, $\beta\beta$ and $\alpha\beta$ stored as -maps, with pysicists notation, consistent with the two-electron integrals in the +arrays, with pysicists notation, consistent with the two-electron integrals in the MO basis. From 81e9590f868296c4522bce88949dc51d56ea1014 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner LCT Date: Mon, 1 Jul 2019 15:30:40 +0200 Subject: [PATCH 25/59] added some missing files --- src/dft_utils_one_e/ec_lyp_2.irp.f | 28 ++++++++ src/dft_utils_one_e/ec_scan_2.irp.f | 100 ++++++++++++++++++++++++++++ 2 files changed, 128 insertions(+) create mode 100644 src/dft_utils_one_e/ec_lyp_2.irp.f create mode 100644 src/dft_utils_one_e/ec_scan_2.irp.f diff --git a/src/dft_utils_one_e/ec_lyp_2.irp.f b/src/dft_utils_one_e/ec_lyp_2.irp.f new file mode 100644 index 00000000..e97a0e00 --- /dev/null +++ b/src/dft_utils_one_e/ec_lyp_2.irp.f @@ -0,0 +1,28 @@ +double precision function ec_lyp2(RhoA,RhoB,GA,GB,GAB) + include 'constants.include.F' + implicit none + double precision, intent(in) :: RhoA,RhoB,GA,GB,GAB + double precision :: Tol,caa,cab,cac,cad,cae,RA,RB,comega,cdelta,cLaa,cLbb,cLab,E + ec_lyp2 = 0.d0 + Tol=1D-14 + E=2.718281828459045D0 + caa=0.04918D0 + cab=0.132D0 + cac=0.2533D0 + cad=0.349D0 + cae=(2D0**(11D0/3D0))*((3D0/10D0)*((3D0*(Pi**2D0))**(2D0/3D0))) + + + RA = MAX(RhoA,0D0) + RB = MAX(RhoB,0D0) + IF ((RA.gt.Tol).OR.(RB.gt.Tol)) THEN + IF ((RA.gt.Tol).AND.(RB.gt.Tol)) THEN + comega = 1D0/(E**(cac/(RA+RB)**(1D0/3D0))*(RA+RB)**(10D0/3D0)*(cad+(RA+RB)**(1D0/3D0))) + cdelta = (cac+cad+(cac*cad)/(RA+RB)**(1D0/3D0))/(cad+(RA+RB)**(1D0/3D0)) + cLaa = (cab*comega*RB*(RA-3D0*cdelta*RA-9D0*RB-((-11D0+cdelta)*RA**2D0)/(RA+RB)))/9D0 + cLbb = (cab*comega*RA*(-9D0*RA+(RB*(RA-3D0*cdelta*RA-4D0*(-3D0+cdelta)*RB))/(RA+RB)))/9D0 + cLab = cab*comega*(((47D0-7D0*cdelta)*RA*RB)/9D0-(4D0*(RA+RB)**2D0)/3D0) + ec_lyp2 = -(caa*(cLaa*GA+cLab*GAB+cLbb*GB+cab*cae*comega*RA*RB*(RA**(8D0/3D0)+RB**(8D0/3D0))+(4D0*RA*RB)/(RA+RB+cad*(RA+RB)**(2D0/3D0)))) + endif + endif +end diff --git a/src/dft_utils_one_e/ec_scan_2.irp.f b/src/dft_utils_one_e/ec_scan_2.irp.f new file mode 100644 index 00000000..4807b89f --- /dev/null +++ b/src/dft_utils_one_e/ec_scan_2.irp.f @@ -0,0 +1,100 @@ +double precision function ec_scan(rho_a,rho_b,tau,grad_rho_2) + include 'constants.include.F' + implicit none + double precision, intent(in) :: rho_a,rho_b,tau,grad_rho_2 + double precision :: cst_13,cst_23,cst_43,cst_53,rho_inv,cst_18,cst_3pi2 + double precision :: thr,nup,ndo,xi,s,spin_d,drho,drho2,rho,inv_1alph,e_c_lsda1,h0 + double precision :: rs,t_w,t_unif,ds_xi,alpha,fc_alpha,step_f,cst_1alph,beta_inf + double precision :: c_1c,c_2c,d_c,e_c_ldsa1,h1,phi,t,beta_rs,gama,a,w_1,g_at2,phi_3,e_c_1 + double precision :: b_1c,b_2c,b_3c,dx_xi,gc_xi,e_c_lsda0,w_0,g_inf,cx_xi,x_inf,f0,e_c_0 + thr = 1.d-12 + nup = max(rho_a,thr) + ndo = max(rho_b,thr) + rho = nup + ndo + ec_scan = 0.d0 + if((rho).lt.thr)return + ! constants ... + rho_inv = 1.d0/rho + cst_13 = 1.d0/3.d0 + cst_23 = 2.d0 * cst_13 + cst_43 = 4.d0 * cst_13 + cst_53 = 5.d0 * cst_13 + cst_18 = 1.d0/8.d0 + cst_3pi2 = 3.d0 * pi*pi + drho2 = max(grad_rho_2,thr) + drho = dsqrt(drho2) + if((nup-ndo).gt.0.d0)then + spin_d = max(nup-ndo,thr) + else + spin_d = min(nup-ndo,-thr) + endif + c_1c = 0.64d0 + c_2c = 1.5d0 + d_c = 0.7d0 + b_1c = 0.0285764d0 + b_2c = 0.0889d0 + b_3c = 0.125541d0 + gama = 0.031091d0 + ! correlation energy lsda1 + call ec_only_lda_sr(0.d0,nup,ndo,e_c_lsda1) + + xi = spin_d/rho + rs = (cst_43 * pi * rho)**(-cst_13) + s = drho/( 2.d0 * cst_3pi2**(cst_13) * rho**cst_43 ) + t_w = drho2 * cst_18 * rho_inv + ds_xi = 0.5d0 * ( (1.d0+xi)**cst_53 + (1.d0 - xi)**cst_53) + t_unif = 0.3d0 * (cst_3pi2)**cst_23 * rho**cst_53*ds_xi + t_unif = max(t_unif,thr) + alpha = (tau - t_w)/t_unif + cst_1alph= 1.d0 - alpha + if(cst_1alph.gt.0.d0)then + cst_1alph= max(cst_1alph,thr) + else + cst_1alph= min(cst_1alph,-thr) + endif + inv_1alph= 1.d0/cst_1alph + phi = 0.5d0 * ( (1.d0+xi)**cst_23 + (1.d0 - xi)**cst_23) + phi_3 = phi*phi*phi + t = (cst_3pi2/16.d0)**cst_13 * s / (phi * rs**0.5d0) + w_1 = dexp(-e_c_lsda1/(gama * phi_3)) - 1.d0 + a = beta_rs(rs) /(gama * w_1) + g_at2 = 1.d0/(1.d0 + 4.d0 * a*t*t)**0.25d0 + h1 = gama * phi_3 * dlog(1.d0 + w_1 * (1.d0 - g_at2)) + ! interpolation function + fc_alpha = dexp(-c_1c * alpha * inv_1alph) * step_f(cst_1alph) - d_c * dexp(c_2c * inv_1alph) * step_f(-cst_1alph) + ! first part of the correlation energy + e_c_1 = e_c_lsda1 + h1 + + dx_xi = 0.5d0 * ( (1.d0+xi)**cst_43 + (1.d0 - xi)**cst_43) + gc_xi = (1.d0 - 2.3631d0 * (dx_xi - 1.d0) ) * (1.d0 - xi**12.d0) + e_c_lsda0= - b_1c / (1.d0 + b_2c * rs**0.5d0 + b_3c * rs) + w_0 = dexp(-e_c_lsda0/b_1c) - 1.d0 + beta_inf = 0.066725d0 * 0.1d0 / 0.1778d0 + cx_xi = -3.d0/(4.d0*pi) * (9.d0 * pi/4.d0)**cst_13 * dx_xi + + x_inf = 0.128026d0 + f0 = -0.9d0 + g_inf = 1.d0/(1.d0 + 4.d0 * x_inf * s*s)**0.25d0 + + h0 = b_1c * dlog(1.d0 + w_0 * (1.d0 - g_inf)) + e_c_0 = (e_c_lsda0 + h0) * gc_xi + + ec_scan = e_c_1 + fc_alpha * (e_c_0 - e_c_1) +end + +double precision function step_f(x) + implicit none + double precision, intent(in) :: x + if(x.lt.0.d0)then + step_f = 0.d0 + else + step_f = 1.d0 + endif +end + +double precision function beta_rs(rs) + implicit none + double precision, intent(in) ::rs + beta_rs = 0.066725d0 * (1.d0 + 0.1d0 * rs)/(1.d0 + 0.1778d0 * rs) + +end From e42a4d8fc5d4fad9a3fee41fd836e067b25da15d Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Mon, 1 Jul 2019 17:20:09 +0200 Subject: [PATCH 26/59] Minor changes --- src/casscf/bielec.irp.f | 30 ++++++------------------------ 1 file changed, 6 insertions(+), 24 deletions(-) diff --git a/src/casscf/bielec.irp.f b/src/casscf/bielec.irp.f index 74351760..8e08243d 100644 --- a/src/casscf/bielec.irp.f +++ b/src/casscf/bielec.irp.f @@ -5,35 +5,22 @@ END_DOC implicit none integer :: i,j,ii,jj,p,q,i3,j3,t3,v3 - double precision, allocatable :: integrals_array(:,:) real*8 :: mo_two_e_integral - allocate(integrals_array(mo_num,mo_num)) - bielec_PQxx = 0.d0 do i=1,n_core_orb ii=list_core(i) do j=i,n_core_orb jj=list_core(j) - call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array,mo_integrals_map) - do p=1,mo_num - do q=1,mo_num - bielec_PQxx(p,q,i,j)=integrals_array(p,q) - bielec_PQxx(p,q,j,i)=integrals_array(p,q) - end do - end do + call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,bielec_PQxx(1,1,i,j),mo_integrals_map) + bielec_PQxx(:,:,j,i)=bielec_PQxx(:,:,i,j) end do do j=1,n_act_orb jj=list_act(j) j3=j+n_core_orb - call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array,mo_integrals_map) - do p=1,mo_num - do q=1,mo_num - bielec_PQxx(p,q,i,j3)=integrals_array(p,q) - bielec_PQxx(p,q,j3,i)=integrals_array(p,q) - end do - end do + call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,bielec_PQxx(1,1,i,j3),mo_integrals_map) + bielec_PQxx(:,:,j3,i)=bielec_PQxx(:,:,i,j3) end do end do @@ -45,13 +32,8 @@ do j=i,n_act_orb jj=list_act(j) j3=j+n_core_orb - call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,integrals_array,mo_integrals_map) - do p=1,mo_num - do q=1,mo_num - bielec_PQxx(p,q,i3,j3)=integrals_array(p,q) - bielec_PQxx(p,q,j3,i3)=integrals_array(p,q) - end do - end do + call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,bielec_PQxx(1,1,i3,j3),mo_integrals_map) + bielec_PQxx(:,:,j3,i3)=bielec_PQxx(:,:,i3,j3) end do end do From 18ef6ab1166189a67f31f09358e152cd470258e8 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner LCT Date: Mon, 1 Jul 2019 17:33:11 +0200 Subject: [PATCH 27/59] adding all states routines properly --- src/density_for_dft/density_for_dft.irp.f | 23 +- .../routines_compute_2rdm_all_states.irp.f | 658 ++++++++++++++++++ 2 files changed, 679 insertions(+), 2 deletions(-) create mode 100644 src/two_body_rdm/routines_compute_2rdm_all_states.irp.f diff --git a/src/density_for_dft/density_for_dft.irp.f b/src/density_for_dft/density_for_dft.irp.f index 4514f111..c925bdf8 100644 --- a/src/density_for_dft/density_for_dft.irp.f +++ b/src/density_for_dft/density_for_dft.irp.f @@ -106,12 +106,31 @@ END_PROVIDER BEGIN_PROVIDER [double precision, one_e_dm_average_mo_for_dft, (mo_num,mo_num)] implicit none integer :: i - one_e_dm_average_mo_for_dft = 0.d0 + one_e_dm_average_mo_for_dft = one_e_dm_average_alpha_mo_for_dft + one_e_dm_average_beta_mo_for_dft +END_PROVIDER + + +BEGIN_PROVIDER [double precision, one_e_dm_average_alpha_mo_for_dft, (mo_num,mo_num)] + implicit none + integer :: i + one_e_dm_average_alpha_mo_for_dft = 0.d0 do i = 1, N_states - one_e_dm_average_mo_for_dft(:,:) += one_e_dm_mo_for_dft(:,:,i) * state_average_weight(i) + one_e_dm_average_alpha_mo_for_dft(:,:) += one_e_dm_mo_alpha_for_dft(:,:,i) * state_average_weight(i) enddo END_PROVIDER + +BEGIN_PROVIDER [double precision, one_e_dm_average_beta_mo_for_dft, (mo_num,mo_num)] + implicit none + integer :: i + one_e_dm_average_beta_mo_for_dft = 0.d0 + do i = 1, N_states + one_e_dm_average_beta_mo_for_dft(:,:) += one_e_dm_mo_beta_for_dft(:,:,i) * state_average_weight(i) + enddo +END_PROVIDER + + + BEGIN_PROVIDER [ double precision, one_e_dm_alpha_ao_for_dft, (ao_num,ao_num,N_states) ] &BEGIN_PROVIDER [ double precision, one_e_dm_beta_ao_for_dft, (ao_num,ao_num,N_states) ] BEGIN_DOC diff --git a/src/two_body_rdm/routines_compute_2rdm_all_states.irp.f b/src/two_body_rdm/routines_compute_2rdm_all_states.irp.f new file mode 100644 index 00000000..27b2dfe3 --- /dev/null +++ b/src/two_body_rdm/routines_compute_2rdm_all_states.irp.f @@ -0,0 +1,658 @@ + + subroutine orb_range_diagonal_contrib_to_two_rdm_ab_dm_all_states(det_1,c_1,N_st,big_array,dim1,orb_bitmask) + use bitmasks + BEGIN_DOC +! routine that update the DIAGONAL PART of the alpha/beta two body rdm in a specific range of orbitals + END_DOC + implicit none + integer, intent(in) :: dim1 + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) + integer(bit_kind), intent(in) :: det_1(N_int,2) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + double precision, intent(in) :: c_1(N_st) + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + do istate = 1, N_st + do i = 1, n_occ_ab(1) + h1 = occ(i,1) + do j = 1, n_occ_ab(2) + h2 = occ(j,2) + big_array(h1,h2,h1,h2,istate) += c_1(istate) + enddo + enddo + enddo + end + + + subroutine orb_range_diagonal_contrib_to_all_two_rdm_dm_all_states(det_1,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + use bitmasks + BEGIN_DOC +! routine that update the DIAGONAL PART of the two body rdms in a specific range of orbitals for a given determinant det_1 +! +! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation +! +! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +! +! ispin determines which spin-spin component of the two-rdm you will update +! +! ispin == 1 :: alpha/ alpha +! ispin == 2 :: beta / beta +! ispin == 3 :: alpha/ beta +! ispin == 4 :: spin traced <=> total two-rdm + END_DOC + implicit none + integer, intent(in) :: dim1,N_st,ispin + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) + integer(bit_kind), intent(in) :: det_1(N_int,2) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + double precision, intent(in) :: c_1(N_st) + + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate + integer(bit_kind) :: det_1_act(N_int,2) + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + do i = 1, N_int + det_1_act(i,1) = iand(det_1(i,1),orb_bitmask(i)) + det_1_act(i,2) = iand(det_1(i,2),orb_bitmask(i)) + enddo + + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + call bitstring_to_list_ab(det_1_act, occ, n_occ_ab, N_int) + logical :: is_integer_in_string + integer :: i1,i2 + if(alpha_beta)then + do istate = 1, N_st + do i = 1, n_occ_ab(1) + i1 = occ(i,1) + do j = 1, n_occ_ab(2) + i2 = occ(j,2) + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + big_array(h1,h2,h1,h2,istate) += c_1(istate) + enddo + enddo + enddo + else if (alpha_alpha)then + do istate = 1, N_st + do i = 1, n_occ_ab(1) + i1 = occ(i,1) + do j = 1, n_occ_ab(1) + i2 = occ(j,1) + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + big_array(h1,h2,h1,h2,istate) += 0.5d0 * c_1(istate) + big_array(h1,h2,h2,h1,istate) -= 0.5d0 * c_1(istate) + enddo + enddo + enddo + else if (beta_beta)then + do istate = 1, N_st + do i = 1, n_occ_ab(2) + i1 = occ(i,2) + do j = 1, n_occ_ab(2) + i2 = occ(j,2) + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + big_array(h1,h2,h1,h2,istate) += 0.5d0 * c_1(istate) + big_array(h1,h2,h2,h1,istate) -= 0.5d0 * c_1(istate) + enddo + enddo + enddo + else if(spin_trace)then + ! 0.5 * (alpha beta + beta alpha) + do istate = 1, N_st + do i = 1, n_occ_ab(1) + i1 = occ(i,1) + do j = 1, n_occ_ab(2) + i2 = occ(j,2) + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + big_array(h1,h2,h1,h2,istate) += 0.5d0 * (c_1 ) + big_array(h2,h1,h2,h1,istate) += 0.5d0 * (c_1 ) + enddo + enddo + do i = 1, n_occ_ab(1) + i1 = occ(i,1) + do j = 1, n_occ_ab(1) + i2 = occ(j,1) + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + big_array(h1,h2,h1,h2,istate) += 0.5d0 * c_1(istate) + big_array(h1,h2,h2,h1,istate) -= 0.5d0 * c_1(istate) + enddo + enddo + do i = 1, n_occ_ab(2) + i1 = occ(i,2) + do j = 1, n_occ_ab(2) + i2 = occ(j,2) + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + big_array(h1,h2,h1,h2,istate) += 0.5d0 * c_1(istate) + big_array(h1,h2,h2,h1,istate) -= 0.5d0 * c_1(istate) + enddo + enddo + enddo + endif + end + + + subroutine orb_range_off_diagonal_double_to_two_rdm_ab_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for +! +! a given couple of determinant det_1, det_2 being a alpha/beta DOUBLE excitation with respect to one another +! +! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 +! +! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation +! +! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +! +! ispin determines which spin-spin component of the two-rdm you will update +! +! ispin == 1 :: alpha/ alpha +! ispin == 2 :: beta / beta +! ispin == 3 :: alpha/ beta +! ispin == 4 :: spin traced <=> total two-rdm +! +! here, only ispin == 3 or 4 will do something + END_DOC + implicit none + integer, intent(in) :: dim1,N_st,ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(in) :: c_1(N_st) + integer :: i,j,h1,h2,p1,p2,istate + integer :: exc(0:2,2,2) + double precision :: phase + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + call get_double_excitation(det_1,det_2,exc,phase,N_int) + h1 = exc(1,1,1) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) + h2 = exc(1,1,2) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return + h2 = list_orb_reverse(h2) + p1 = exc(1,2,1) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) + p2 = exc(1,2,2) + if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return + p2 = list_orb_reverse(p2) + do istate = 1, N_st + if(alpha_beta)then + big_array(h1,h2,p1,p2,istate) += c_1(istate) * phase + else if(spin_trace)then + big_array(h1,h2,p1,p2,istate) += 0.5d0 * c_1(istate) * phase + big_array(p1,p2,h1,h2,istate) += 0.5d0 * c_1(istate) * phase + endif + enddo + end + + subroutine orb_range_off_diagonal_single_to_two_rdm_ab_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for +! +! a given couple of determinant det_1, det_2 being a SINGLE excitation with respect to one another +! +! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 +! +! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation +! +! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +! +! ispin determines which spin-spin component of the two-rdm you will update +! +! ispin == 1 :: alpha/ alpha +! ispin == 2 :: beta / beta +! ispin == 3 :: alpha/ beta +! ispin == 4 :: spin traced <=> total two-rdm +! +! here, only ispin == 3 or 4 will do something + END_DOC + implicit none + integer, intent(in) :: dim1,N_st,ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(in) :: c_1(N_st) + + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate,p1 + integer :: exc(0:2,2,2) + double precision :: phase + + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + call get_single_excitation(det_1,det_2,exc,phase,N_int) + if(alpha_beta)then + do istate = 1, N_st + if (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,1) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle + h2 = list_orb_reverse(h2) + big_array(h1,h2,p1,h2,istate) += c_1(istate) * phase + enddo + else + ! Mono beta + h1 = exc(1,1,2) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,2) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle + h2 = list_orb_reverse(h2) + big_array(h2,h1,h2,p1,istate) += c_1(istate) * phase + enddo + endif + enddo + else if(spin_trace)then + if (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,1) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) + do istate = 1, N_st + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle + h2 = list_orb_reverse(h2) + big_array(h1,h2,p1,h2,istate) += 0.5d0 * c_1(istate) * phase + big_array(h2,h1,h2,p1,istate) += 0.5d0 * c_1(istate) * phase + enddo + enddo + else + ! Mono beta + h1 = exc(1,1,2) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,2) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle + h2 = list_orb_reverse(h2) + big_array(h1,h2,p1,h2,istate) += 0.5d0 * c_1(istate) * phase + big_array(h2,h1,h2,p1,istate) += 0.5d0 * c_1(istate) * phase + enddo + endif + endif + end + + subroutine orb_range_off_diagonal_single_to_two_rdm_aa_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for +! +! a given couple of determinant det_1, det_2 being a ALPHA SINGLE excitation with respect to one another +! +! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 +! +! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation +! +! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +! +! ispin determines which spin-spin component of the two-rdm you will update +! +! ispin == 1 :: alpha/ alpha +! ispin == 2 :: beta / beta +! ispin == 3 :: alpha/ beta +! ispin == 4 :: spin traced <=> total two-rdm +! +! here, only ispin == 1 or 4 will do something + END_DOC + use bitmasks + implicit none + integer, intent(in) :: dim1,N_st,ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(in) :: c_1(N_st) + + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate,p1 + integer :: exc(0:2,2,2) + double precision :: phase + + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + call get_single_excitation(det_1,det_2,exc,phase,N_int) + if(alpha_alpha.or.spin_trace)then + if (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,1) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) + do istate = 1, N_st + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle + h2 = list_orb_reverse(h2) + big_array(h1,h2,p1,h2,istate) += 0.5d0 * c_1(istate) * phase + big_array(h1,h2,h2,p1,istate) -= 0.5d0 * c_1(istate) * phase + + big_array(h2,h1,h2,p1,istate) += 0.5d0 * c_1(istate) * phase + big_array(h2,h1,p1,h2,istate) -= 0.5d0 * c_1(istate) * phase + enddo + enddo + else + return + endif + endif + end + + subroutine orb_range_off_diagonal_single_to_two_rdm_bb_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for +! +! a given couple of determinant det_1, det_2 being a BETA SINGLE excitation with respect to one another +! +! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 +! +! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation +! +! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +! +! ispin determines which spin-spin component of the two-rdm you will update +! +! ispin == 1 :: alpha/ alpha +! ispin == 2 :: beta / beta +! ispin == 3 :: alpha/ beta +! ispin == 4 :: spin traced <=> total two-rdm +! +! here, only ispin == 2 or 4 will do something + END_DOC + implicit none + integer, intent(in) :: dim1,N_st,ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(in) :: c_1(N_st) + + + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate,p1 + integer :: exc(0:2,2,2) + double precision :: phase + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + + + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + call get_single_excitation(det_1,det_2,exc,phase,N_int) + if(beta_beta.or.spin_trace)then + if (exc(0,1,1) == 1) then + return + else + ! Mono beta + h1 = exc(1,1,2) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,2) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) + do istate = 1, N_st + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle + h2 = list_orb_reverse(h2) + big_array(h1,h2,p1,h2,istate) += 0.5d0 * c_1(istate) * phase + big_array(h1,h2,h2,p1,istate) -= 0.5d0 * c_1(istate) * phase + + big_array(h2,h1,h2,p1,istate) += 0.5d0 * c_1(istate) * phase + big_array(h2,h1,p1,h2,istate) -= 0.5d0 * c_1(istate) * phase + enddo + enddo + endif + endif + end + + + subroutine orb_range_off_diagonal_double_to_two_rdm_aa_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for +! +! a given couple of determinant det_1, det_2 being a ALPHA/ALPHA DOUBLE excitation with respect to one another +! +! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 +! +! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation +! +! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +! +! ispin determines which spin-spin component of the two-rdm you will update +! +! ispin == 1 :: alpha/ alpha +! ispin == 2 :: beta / beta +! ispin == 3 :: alpha/ beta +! ispin == 4 :: spin traced <=> total two-rdm +! +! here, only ispin == 1 or 4 will do something + END_DOC + implicit none + integer, intent(in) :: dim1,N_st,ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) + integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(in) :: c_1(N_st) + + integer :: i,j,h1,h2,p1,p2,istate + integer :: exc(0:2,2) + double precision :: phase + + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) + h1 =exc(1,1) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) + h2 =exc(2,1) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return + h2 = list_orb_reverse(h2) + p1 =exc(1,2) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) + p2 =exc(2,2) + if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return + p2 = list_orb_reverse(p2) + if(alpha_alpha.or.spin_trace)then + do istate = 1, N_st + big_array(h1,h2,p1,p2,istate) += 0.5d0 * c_1(istate) * phase + big_array(h1,h2,p2,p1,istate) -= 0.5d0 * c_1(istate) * phase + + big_array(h2,h1,p2,p1,istate) += 0.5d0 * c_1(istate) * phase + big_array(h2,h1,p1,p2,istate) -= 0.5d0 * c_1(istate) * phase + enddo + endif + end + + subroutine orb_range_off_diagonal_double_to_two_rdm_bb_dm_all_states(det_1,det_2,c_1,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for +! +! a given couple of determinant det_1, det_2 being a BETA /BETA DOUBLE excitation with respect to one another +! +! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 +! +! big_array(dim1,dim1,dim1,dim1,N_st) is the two-body rdm to be updated in physicist notation +! +! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +! +! ispin determines which spin-spin component of the two-rdm you will update +! +! ispin == 1 :: alpha/ alpha +! ispin == 2 :: beta / beta +! ispin == 3 :: alpha/ beta +! ispin == 4 :: spin traced <=> total two-rdm +! +! here, only ispin == 2 or 4 will do something + END_DOC + implicit none + + integer, intent(in) :: dim1,N_st,ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) + integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(in) :: c_1(N_st) + + integer :: i,j,h1,h2,p1,p2,istate + integer :: exc(0:2,2) + double precision :: phase + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + + call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) + h1 =exc(1,1) + if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return + h1 = list_orb_reverse(h1) + h2 =exc(2,1) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return + h2 = list_orb_reverse(h2) + p1 =exc(1,2) + if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return + p1 = list_orb_reverse(p1) + p2 =exc(2,2) + if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return + p2 = list_orb_reverse(p2) + do istate = 1, N_st + if(beta_beta.or.spin_trace)then + big_array(h1,h2,p1,p2,istate) += 0.5d0 * c_1(istate)* phase + big_array(h1,h2,p2,p1,istate) -= 0.5d0 * c_1(istate)* phase + + big_array(h2,h1,p2,p1,istate) += 0.5d0 * c_1(istate)* phase + big_array(h2,h1,p1,p2,istate) -= 0.5d0 * c_1(istate)* phase + endif + enddo + end + From 39da8cad5b0f993e15eaf54bedbc4f61e346ebb2 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner LCT Date: Mon, 1 Jul 2019 17:49:31 +0200 Subject: [PATCH 28/59] renamed two-rdm for explicit separation between all states and state average --- src/casscf/densities.irp.f | 2 +- src/two_body_rdm/all_states_2_rdm.irp.f | 83 ++++ src/two_body_rdm/all_states_routines.irp.f | 495 +++++++++++++++++++++ src/two_body_rdm/orb_range_2_rdm.irp.f | 36 +- src/two_body_rdm/orb_range_routines.irp.f | 20 +- 5 files changed, 607 insertions(+), 29 deletions(-) create mode 100644 src/two_body_rdm/all_states_2_rdm.irp.f create mode 100644 src/two_body_rdm/all_states_routines.irp.f diff --git a/src/casscf/densities.irp.f b/src/casscf/densities.irp.f index 3cfd7583..88c9021d 100644 --- a/src/casscf/densities.irp.f +++ b/src/casscf/densities.irp.f @@ -56,7 +56,7 @@ BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ] uu = list_act(u) do t = 1, n_act_orb tt = list_act(t) - P0tuvx(t,u,v,x) = act_two_rdm_spin_trace_mo(t,v,u,x) + P0tuvx(t,u,v,x) = state_av_act_two_rdm_spin_trace_mo(t,v,u,x) enddo enddo enddo diff --git a/src/two_body_rdm/all_states_2_rdm.irp.f b/src/two_body_rdm/all_states_2_rdm.irp.f new file mode 100644 index 00000000..b168da56 --- /dev/null +++ b/src/two_body_rdm/all_states_2_rdm.irp.f @@ -0,0 +1,83 @@ + + + + BEGIN_PROVIDER [double precision, all_states_act_two_rdm_alpha_alpha_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)] + implicit none + double precision, allocatable :: state_weights(:) + BEGIN_DOC +! all_states_act_two_rdm_alpha_alpha_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-alpha electron pairs +! = + END_DOC + allocate(state_weights(N_states)) + state_weights = 1.d0/dble(N_states) + integer :: ispin + ! condition for alpha/beta spin + ispin = 1 + all_states_act_two_rdm_alpha_alpha_mo = 0.D0 + call orb_range_all_states_two_rdm_openmp(all_states_act_two_rdm_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + + END_PROVIDER + + BEGIN_PROVIDER [double precision, all_states_act_two_rdm_beta_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)] + implicit none + double precision, allocatable :: state_weights(:) + BEGIN_DOC +! all_states_act_two_rdm_beta_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for beta-beta electron pairs +! = + END_DOC + allocate(state_weights(N_states)) + state_weights = 1.d0/dble(N_states) + integer :: ispin + ! condition for alpha/beta spin + ispin = 2 + all_states_act_two_rdm_beta_beta_mo = 0.d0 + call orb_range_all_states_two_rdm_openmp(all_states_act_two_rdm_beta_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + + END_PROVIDER + + BEGIN_PROVIDER [double precision, all_states_act_two_rdm_alpha_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)] + implicit none + double precision, allocatable :: state_weights(:) + BEGIN_DOC +! all_states_act_two_rdm_alpha_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-beta electron pairs +! = + END_DOC + allocate(state_weights(N_states)) + state_weights = 1.d0/dble(N_states) + integer :: ispin + ! condition for alpha/beta spin + print*,'' + print*,'' + print*,'' + print*,'providint all_states_act_two_rdm_alpha_beta_mo ' + ispin = 3 + print*,'ispin = ',ispin + all_states_act_two_rdm_alpha_beta_mo = 0.d0 + call orb_range_all_states_two_rdm_openmp(all_states_act_two_rdm_alpha_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + + END_PROVIDER + + + BEGIN_PROVIDER [double precision, all_states_act_two_rdm_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb,N_states)] + implicit none + BEGIN_DOC +! all_states_act_two_rdm_spin_trace_mo(i,j,k,l) = state average physicist spin trace two-body rdm restricted to the ACTIVE indices +! The active part of the two-electron energy can be computed as: +! +! \sum_{i,j,k,l = 1, n_act_orb} all_states_act_two_rdm_spin_trace_mo(i,j,k,l) * < ii jj | kk ll > +! +! with ii = list_act(i), jj = list_act(j), kk = list_act(k), ll = list_act(l) + END_DOC + double precision, allocatable :: state_weights(:) + allocate(state_weights(N_states)) + state_weights = 1.d0/dble(N_states) + integer :: ispin + ! condition for alpha/beta spin + ispin = 4 + all_states_act_two_rdm_spin_trace_mo = 0.d0 + integer :: i + + call orb_range_all_states_two_rdm_openmp(all_states_act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + + END_PROVIDER + diff --git a/src/two_body_rdm/all_states_routines.irp.f b/src/two_body_rdm/all_states_routines.irp.f new file mode 100644 index 00000000..b8888299 --- /dev/null +++ b/src/two_body_rdm/all_states_routines.irp.f @@ -0,0 +1,495 @@ +subroutine orb_range_all_states_two_rdm_openmp(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_0,N_st,sze) + use bitmasks + implicit none + BEGIN_DOC + ! if ispin == 1 :: alpha/alpha 2rdm + ! == 2 :: beta /beta 2rdm + ! == 3 :: alpha/beta 2rdm + ! == 4 :: spin traced 2rdm :: aa + bb + 0.5 (ab + ba)) + ! + ! Assumes that the determinants are in psi_det + ! + ! istart, iend, ishift, istep are used in ZMQ parallelization. + END_DOC + integer, intent(in) :: N_st,sze + integer, intent(in) :: dim1,norb,list_orb(norb),ispin + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) + double precision, intent(in) :: u_0(sze,N_st) + + integer :: k + double precision, allocatable :: u_t(:,:) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t + allocate(u_t(N_st,N_det)) + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det) + enddo + call dtranspose( & + u_0, & + size(u_0, 1), & + u_t, & + size(u_t, 1), & + N_det, N_st) + + call orb_range_all_states_two_rdm_openmp_work(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,1,N_det,0,1) + deallocate(u_t) + + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det) + enddo + +end + +subroutine orb_range_all_states_two_rdm_openmp_work(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + BEGIN_DOC + ! Computes two-rdm + ! + ! Default should be 1,N_det,0,1 + END_DOC + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + integer, intent(in) :: dim1,norb,list_orb(norb),ispin + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) + double precision, intent(in) :: u_t(N_st,N_det) + + integer :: k + + PROVIDE N_int + + select case (N_int) + case (1) + call orb_range_all_states_two_rdm_openmp_work_1(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + case (2) + call orb_range_all_states_two_rdm_openmp_work_2(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + case (3) + call orb_range_all_states_two_rdm_openmp_work_3(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + case (4) + call orb_range_all_states_two_rdm_openmp_work_4(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + case default + call orb_range_all_states_two_rdm_openmp_work_N_int(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + end select +end + + + + + BEGIN_TEMPLATE +subroutine orb_range_all_states_two_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + BEGIN_DOC + ! Computes the two rdm for the N_st vectors |u_t> + ! if ispin == 1 :: alpha/alpha 2rdm + ! == 2 :: beta /beta 2rdm + ! == 3 :: alpha/beta 2rdm + ! == 4 :: spin traced 2rdm :: aa + bb + 0.5 (ab + ba)) + ! The 2rdm will be computed only on the list of orbitals list_orb, which contains norb + ! Default should be 1,N_det,0,1 for istart,iend,ishift,istep + END_DOC + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + double precision, intent(in) :: u_t(N_st,N_det) + integer, intent(in) :: dim1,norb,list_orb(norb),ispin + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) + + integer :: i,j,k,l + integer :: k_a, k_b, l_a, l_b, m_a, m_b + integer :: istate + integer :: krow, kcol, krow_b, kcol_b + integer :: lrow, lcol + integer :: mrow, mcol + integer(bit_kind) :: spindet($N_int) + integer(bit_kind) :: tmp_det($N_int,2) + integer(bit_kind) :: tmp_det2($N_int,2) + integer(bit_kind) :: tmp_det3($N_int,2) + integer(bit_kind), allocatable :: buffer(:,:) + integer :: n_doubles + integer, allocatable :: doubles(:) + integer, allocatable :: singles_a(:) + integer, allocatable :: singles_b(:) + integer, allocatable :: idx(:), idx0(:) + integer :: maxab, n_singles_a, n_singles_b, kcol_prev + integer*8 :: k8 + double precision,allocatable :: c_contrib(:) + + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + integer(bit_kind) :: orb_bitmask($N_int) + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + else + print*,'Wrong parameter for ispin in general_two_rdm_dm_nstates_openmp_work' + print*,'ispin = ',ispin + stop + endif + + PROVIDE N_int + + call list_to_bitstring( orb_bitmask, list_orb, norb, N_int) + + maxab = max(N_det_alpha_unique, N_det_beta_unique)+1 + allocate(idx0(maxab)) + + do i=1,maxab + idx0(i) = i + enddo + + ! Prepare the array of all alpha single excitations + ! ------------------------------------------------- + + PROVIDE N_int nthreads_davidson + !!$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) & + ! !$OMP SHARED(psi_bilinear_matrix_rows, N_det, & + ! !$OMP psi_bilinear_matrix_columns, & + ! !$OMP psi_det_alpha_unique, psi_det_beta_unique,& + ! !$OMP n_det_alpha_unique, n_det_beta_unique, N_int,& + ! !$OMP psi_bilinear_matrix_transp_rows, & + ! !$OMP psi_bilinear_matrix_transp_columns, & + ! !$OMP psi_bilinear_matrix_transp_order, N_st, & + ! !$OMP psi_bilinear_matrix_order_transp_reverse, & + ! !$OMP psi_bilinear_matrix_columns_loc, & + ! !$OMP psi_bilinear_matrix_transp_rows_loc, & + ! !$OMP istart, iend, istep, irp_here, v_t, s_t, & + ! !$OMP ishift, idx0, u_t, maxab) & + ! !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,& + ! !$OMP lcol, lrow, l_a, l_b, & + ! !$OMP buffer, doubles, n_doubles, & + ! !$OMP tmp_det2, idx, l, kcol_prev, & + ! !$OMP singles_a, n_singles_a, singles_b, & + ! !$OMP n_singles_b, k8) + + ! Alpha/Beta double excitations + ! ============================= + + allocate( buffer($N_int,maxab), & + singles_a(maxab), & + singles_b(maxab), & + doubles(maxab), & + idx(maxab),c_contrib(N_st)) + + kcol_prev=-1 + + ASSERT (iend <= N_det) + ASSERT (istart > 0) + ASSERT (istep > 0) + + !!$OMP DO SCHEDULE(dynamic,64) + do k_a=istart+ishift,iend,istep + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + if (kcol /= kcol_prev) then + call get_all_spin_singles_$N_int( & + psi_det_beta_unique, idx0, & + tmp_det(1,2), N_det_beta_unique, & + singles_b, n_singles_b) + endif + kcol_prev = kcol + + ! Loop over singly excited beta columns + ! ------------------------------------- + + do i=1,n_singles_b + lcol = singles_b(i) + + tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol) + + l_a = psi_bilinear_matrix_columns_loc(lcol) + ASSERT (l_a <= N_det) + + do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow) + + ASSERT (l_a <= N_det) + idx(j) = l_a + l_a = l_a+1 + enddo + j = j-1 + + call get_all_spin_singles_$N_int( & + buffer, idx, tmp_det(1,1), j, & + singles_a, n_singles_a ) + + ! Loop over alpha singles + ! ----------------------- + + if(alpha_beta.or.spin_trace)then + do k = 1,n_singles_a + l_a = singles_a(k) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) + c_contrib = 0.d0 + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + c_contrib(l) = c_1(l) * c_2(l) + enddo + call orb_range_off_diagonal_double_to_two_rdm_ab_dm(tmp_det,tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + enddo + endif + + enddo + + enddo + ! !$OMP END DO + + ! !$OMP DO SCHEDULE(dynamic,64) + do k_a=istart+ishift,iend,istep + + + ! Single and double alpha exitations + ! =================================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + ! Initial determinant is at k_b in beta-major representation + ! ---------------------------------------------------------------------- + + k_b = psi_bilinear_matrix_order_transp_reverse(k_a) + ASSERT (k_b <= N_det) + + spindet(1:$N_int) = tmp_det(1:$N_int,1) + + ! Loop inside the beta column to gather all the connected alphas + lcol = psi_bilinear_matrix_columns(k_a) + l_a = psi_bilinear_matrix_columns_loc(lcol) + do i=1,N_det_alpha_unique + if (l_a > N_det) exit + lcol = psi_bilinear_matrix_columns(l_a) + if (lcol /= kcol) exit + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow) + idx(i) = l_a + l_a = l_a+1 + enddo + i = i-1 + + call get_all_spin_singles_and_doubles_$N_int( & + buffer, idx, spindet, i, & + singles_a, doubles, n_singles_a, n_doubles ) + + ! Compute Hij for all alpha singles + ! ---------------------------------- + + tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + do i=1,n_singles_a + l_a = singles_a(i) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) + c_contrib = 0.d0 + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + c_contrib(l) = c_1(l) * c_2(l) + enddo + if(alpha_beta.or.spin_trace.or.alpha_alpha)then + ! increment the alpha/beta part for single excitations + call orb_range_off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + ! increment the alpha/alpha part for single excitations + call orb_range_off_diagonal_single_to_two_rdm_aa_dm(tmp_det,tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + endif + + enddo + + + ! Compute Hij for all alpha doubles + ! ---------------------------------- + + if(alpha_alpha.or.spin_trace)then + do i=1,n_doubles + l_a = doubles(i) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + c_contrib = 0.d0 + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + c_contrib(l) += c_1(l) * c_2(l) + enddo + call orb_range_off_diagonal_double_to_two_rdm_aa_dm(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + enddo + endif + + + ! Single and double beta excitations + ! ================================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + kcol = psi_bilinear_matrix_columns(k_a) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + spindet(1:$N_int) = tmp_det(1:$N_int,2) + + ! Initial determinant is at k_b in beta-major representation + ! ----------------------------------------------------------------------- + + k_b = psi_bilinear_matrix_order_transp_reverse(k_a) + ASSERT (k_b <= N_det) + + ! Loop inside the alpha row to gather all the connected betas + lrow = psi_bilinear_matrix_transp_rows(k_b) + l_b = psi_bilinear_matrix_transp_rows_loc(lrow) + do i=1,N_det_beta_unique + if (l_b > N_det) exit + lrow = psi_bilinear_matrix_transp_rows(l_b) + if (lrow /= krow) exit + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol) + idx(i) = l_b + l_b = l_b+1 + enddo + i = i-1 + + call get_all_spin_singles_and_doubles_$N_int( & + buffer, idx, spindet, i, & + singles_b, doubles, n_singles_b, n_doubles ) + + ! Compute Hij for all beta singles + ! ---------------------------------- + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + do i=1,n_singles_b + l_b = singles_b(i) + ASSERT (l_b <= N_det) + + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol) + l_a = psi_bilinear_matrix_transp_order(l_b) + c_contrib = 0.d0 + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + c_contrib(l) = c_1(l) * c_2(l) + enddo + if(alpha_beta.or.spin_trace.or.beta_beta)then + ! increment the alpha/beta part for single excitations + call orb_range_off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + ! increment the beta /beta part for single excitations + call orb_range_off_diagonal_single_to_two_rdm_bb_dm(tmp_det, tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + endif + enddo + + ! Compute Hij for all beta doubles + ! ---------------------------------- + + if(beta_beta.or.spin_trace)then + do i=1,n_doubles + l_b = doubles(i) + ASSERT (l_b <= N_det) + + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + l_a = psi_bilinear_matrix_transp_order(l_b) + c_contrib = 0.d0 + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + c_contrib(l) = c_1(l) * c_2(l) + enddo + call orb_range_off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_alpha_unique(1, lcol),c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + ASSERT (l_a <= N_det) + + enddo + endif + + + ! Diagonal contribution + ! ===================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + double precision, external :: diag_wee_mat_elem, diag_S_mat_elem + + double precision :: c_1(N_states),c_2(N_states) + c_contrib = 0.d0 + do l = 1, N_states + c_1(l) = u_t(l,k_a) + c_contrib(l) += c_1(l) * c_1(l) + enddo + + call orb_range_diagonal_contrib_to_all_two_rdm_dm(tmp_det,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + + end do + !!$OMP END DO + deallocate(buffer, singles_a, singles_b, doubles, idx) + !!$OMP END PARALLEL + +end + + SUBST [ N_int ] + + 1;; + 2;; + 3;; + 4;; + N_int;; + + END_TEMPLATE + diff --git a/src/two_body_rdm/orb_range_2_rdm.irp.f b/src/two_body_rdm/orb_range_2_rdm.irp.f index c40c46d2..8a47f73b 100644 --- a/src/two_body_rdm/orb_range_2_rdm.irp.f +++ b/src/two_body_rdm/orb_range_2_rdm.irp.f @@ -1,11 +1,11 @@ - BEGIN_PROVIDER [double precision, act_two_rdm_alpha_alpha_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + BEGIN_PROVIDER [double precision, state_av_act_two_rdm_alpha_alpha_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] implicit none double precision, allocatable :: state_weights(:) BEGIN_DOC -! act_two_rdm_alpha_alpha_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-alpha electron pairs +! state_av_act_two_rdm_alpha_alpha_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-alpha electron pairs ! = END_DOC allocate(state_weights(N_states)) @@ -13,16 +13,16 @@ integer :: ispin ! condition for alpha/beta spin ispin = 1 - act_two_rdm_alpha_alpha_mo = 0.D0 - call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + state_av_act_two_rdm_alpha_alpha_mo = 0.D0 + call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) END_PROVIDER - BEGIN_PROVIDER [double precision, act_two_rdm_beta_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + BEGIN_PROVIDER [double precision, state_av_act_two_rdm_beta_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] implicit none double precision, allocatable :: state_weights(:) BEGIN_DOC -! act_two_rdm_beta_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for beta-beta electron pairs +! state_av_act_two_rdm_beta_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for beta-beta electron pairs ! = END_DOC allocate(state_weights(N_states)) @@ -30,16 +30,16 @@ integer :: ispin ! condition for alpha/beta spin ispin = 2 - act_two_rdm_beta_beta_mo = 0.d0 - call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_beta_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + state_av_act_two_rdm_beta_beta_mo = 0.d0 + call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_beta_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) END_PROVIDER - BEGIN_PROVIDER [double precision, act_two_rdm_alpha_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + BEGIN_PROVIDER [double precision, state_av_act_two_rdm_alpha_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] implicit none double precision, allocatable :: state_weights(:) BEGIN_DOC -! act_two_rdm_alpha_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-beta electron pairs +! state_av_act_two_rdm_alpha_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-beta electron pairs ! = END_DOC allocate(state_weights(N_states)) @@ -49,22 +49,22 @@ print*,'' print*,'' print*,'' - print*,'providint act_two_rdm_alpha_beta_mo ' + print*,'providint state_av_act_two_rdm_alpha_beta_mo ' ispin = 3 print*,'ispin = ',ispin - act_two_rdm_alpha_beta_mo = 0.d0 - call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_alpha_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + state_av_act_two_rdm_alpha_beta_mo = 0.d0 + call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_alpha_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) END_PROVIDER - BEGIN_PROVIDER [double precision, act_two_rdm_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + BEGIN_PROVIDER [double precision, state_av_act_two_rdm_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] implicit none BEGIN_DOC -! act_two_rdm_spin_trace_mo(i,j,k,l) = state average physicist spin trace two-body rdm restricted to the ACTIVE indices +! state_av_act_two_rdm_spin_trace_mo(i,j,k,l) = state average physicist spin trace two-body rdm restricted to the ACTIVE indices ! The active part of the two-electron energy can be computed as: ! -! \sum_{i,j,k,l = 1, n_act_orb} act_two_rdm_spin_trace_mo(i,j,k,l) * < ii jj | kk ll > +! \sum_{i,j,k,l = 1, n_act_orb} state_av_act_two_rdm_spin_trace_mo(i,j,k,l) * < ii jj | kk ll > ! ! with ii = list_act(i), jj = list_act(j), kk = list_act(k), ll = list_act(l) END_DOC @@ -74,10 +74,10 @@ integer :: ispin ! condition for alpha/beta spin ispin = 4 - act_two_rdm_spin_trace_mo = 0.d0 + state_av_act_two_rdm_spin_trace_mo = 0.d0 integer :: i - call orb_range_two_rdm_dm_nstates_openmp(act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) END_PROVIDER diff --git a/src/two_body_rdm/orb_range_routines.irp.f b/src/two_body_rdm/orb_range_routines.irp.f index 0157c46b..b82c4799 100644 --- a/src/two_body_rdm/orb_range_routines.irp.f +++ b/src/two_body_rdm/orb_range_routines.irp.f @@ -1,4 +1,4 @@ -subroutine orb_range_two_rdm_dm_nstates_openmp(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_0,N_st,sze) +subroutine orb_range_two_rdm_state_av_openmp(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_0,N_st,sze) use bitmasks implicit none BEGIN_DOC @@ -31,7 +31,7 @@ subroutine orb_range_two_rdm_dm_nstates_openmp(big_array,dim1,norb,list_orb,list size(u_t, 1), & N_det, N_st) - call orb_range_two_rdm_dm_nstates_openmp_work(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,1,N_det,0,1) + call orb_range_two_rdm_state_av_openmp_work(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,1,N_det,0,1) deallocate(u_t) do k=1,N_st @@ -40,7 +40,7 @@ subroutine orb_range_two_rdm_dm_nstates_openmp(big_array,dim1,norb,list_orb,list end -subroutine orb_range_two_rdm_dm_nstates_openmp_work(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) +subroutine orb_range_two_rdm_state_av_openmp_work(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) use bitmasks implicit none BEGIN_DOC @@ -60,15 +60,15 @@ subroutine orb_range_two_rdm_dm_nstates_openmp_work(big_array,dim1,norb,list_orb select case (N_int) case (1) - call orb_range_two_rdm_dm_nstates_openmp_work_1(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_two_rdm_state_av_openmp_work_1(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) case (2) - call orb_range_two_rdm_dm_nstates_openmp_work_2(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_two_rdm_state_av_openmp_work_2(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) case (3) - call orb_range_two_rdm_dm_nstates_openmp_work_3(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_two_rdm_state_av_openmp_work_3(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) case (4) - call orb_range_two_rdm_dm_nstates_openmp_work_4(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_two_rdm_state_av_openmp_work_4(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) case default - call orb_range_two_rdm_dm_nstates_openmp_work_N_int(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_two_rdm_state_av_openmp_work_N_int(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) end select end @@ -76,7 +76,7 @@ end BEGIN_TEMPLATE -subroutine orb_range_two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) +subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) use bitmasks implicit none BEGIN_DOC @@ -130,7 +130,7 @@ subroutine orb_range_two_rdm_dm_nstates_openmp_work_$N_int(big_array,dim1,norb,l else if(ispin == 4)then spin_trace = .True. else - print*,'Wrong parameter for ispin in general_two_rdm_dm_nstates_openmp_work' + print*,'Wrong parameter for ispin in general_two_rdm_state_av_openmp_work' print*,'ispin = ',ispin stop endif From 7df2c2a20c0081cf90241ec98c8011b6d4c5b37c Mon Sep 17 00:00:00 2001 From: Emmanuel Giner LCT Date: Mon, 1 Jul 2019 18:30:23 +0200 Subject: [PATCH 29/59] trying to do stuffs in multi state rdms --- src/casscf/get_energy.irp.f | 2 +- src/two_body_rdm/all_states_2_rdm.irp.f | 8 ++++---- src/two_body_rdm/routines_compute_2rdm_all_states.irp.f | 8 +++++--- 3 files changed, 10 insertions(+), 8 deletions(-) diff --git a/src/casscf/get_energy.irp.f b/src/casscf/get_energy.irp.f index 0a5cfb49..2a595fe7 100644 --- a/src/casscf/get_energy.irp.f +++ b/src/casscf/get_energy.irp.f @@ -27,7 +27,7 @@ subroutine routine do ii = 1, n_act_orb i = list_act(ii) integral = get_two_e_integral(i,j,k,l,mo_integrals_map) - accu(1) += act_two_rdm_spin_trace_mo(ii,jj,kk,ll) * integral + accu(1) += state_av_act_two_rdm_spin_trace_mo(ii,jj,kk,ll) * integral enddo enddo enddo diff --git a/src/two_body_rdm/all_states_2_rdm.irp.f b/src/two_body_rdm/all_states_2_rdm.irp.f index b168da56..cd74758f 100644 --- a/src/two_body_rdm/all_states_2_rdm.irp.f +++ b/src/two_body_rdm/all_states_2_rdm.irp.f @@ -14,7 +14,7 @@ ! condition for alpha/beta spin ispin = 1 all_states_act_two_rdm_alpha_alpha_mo = 0.D0 - call orb_range_all_states_two_rdm_openmp(all_states_act_two_rdm_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call orb_range_all_states_two_rdm_openmp(all_states_act_two_rdm_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) END_PROVIDER @@ -31,7 +31,7 @@ ! condition for alpha/beta spin ispin = 2 all_states_act_two_rdm_beta_beta_mo = 0.d0 - call orb_range_all_states_two_rdm_openmp(all_states_act_two_rdm_beta_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call orb_range_all_states_two_rdm_openmp(all_states_act_two_rdm_beta_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) END_PROVIDER @@ -53,7 +53,7 @@ ispin = 3 print*,'ispin = ',ispin all_states_act_two_rdm_alpha_beta_mo = 0.d0 - call orb_range_all_states_two_rdm_openmp(all_states_act_two_rdm_alpha_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call orb_range_all_states_two_rdm_openmp(all_states_act_two_rdm_alpha_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) END_PROVIDER @@ -77,7 +77,7 @@ all_states_act_two_rdm_spin_trace_mo = 0.d0 integer :: i - call orb_range_all_states_two_rdm_openmp(all_states_act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call orb_range_all_states_two_rdm_openmp(all_states_act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) END_PROVIDER diff --git a/src/two_body_rdm/routines_compute_2rdm_all_states.irp.f b/src/two_body_rdm/routines_compute_2rdm_all_states.irp.f index 27b2dfe3..7606e353 100644 --- a/src/two_body_rdm/routines_compute_2rdm_all_states.irp.f +++ b/src/two_body_rdm/routines_compute_2rdm_all_states.irp.f @@ -5,7 +5,7 @@ ! routine that update the DIAGONAL PART of the alpha/beta two body rdm in a specific range of orbitals END_DOC implicit none - integer, intent(in) :: dim1 + integer, intent(in) :: dim1,N_st double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1,N_st) integer(bit_kind), intent(in) :: det_1(N_int,2) integer(bit_kind), intent(in) :: orb_bitmask(N_int) @@ -123,8 +123,8 @@ i2 = occ(j,2) h1 = list_orb_reverse(i1) h2 = list_orb_reverse(i2) - big_array(h1,h2,h1,h2,istate) += 0.5d0 * (c_1 ) - big_array(h2,h1,h2,h1,istate) += 0.5d0 * (c_1 ) + big_array(h1,h2,h1,h2,istate) += 0.5d0 * c_1(istate) + big_array(h2,h1,h2,h1,istate) += 0.5d0 * c_1(istate) enddo enddo do i = 1, n_occ_ab(1) @@ -334,6 +334,7 @@ p1 = exc(1,2,2) if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return p1 = list_orb_reverse(p1) + do istate = 1, N_st do i = 1, n_occ_ab(1) h2 = occ(i,1) if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle @@ -341,6 +342,7 @@ big_array(h1,h2,p1,h2,istate) += 0.5d0 * c_1(istate) * phase big_array(h2,h1,h2,p1,istate) += 0.5d0 * c_1(istate) * phase enddo + enddo endif endif end From c6e59030de7226d859c00ed4a8c4c76e72327409 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner LCT Date: Tue, 2 Jul 2019 08:55:51 +0200 Subject: [PATCH 30/59] all states 2rdm work --- src/two_body_rdm/all_states_routines.irp.f | 30 +++++++++++----------- 1 file changed, 15 insertions(+), 15 deletions(-) diff --git a/src/two_body_rdm/all_states_routines.irp.f b/src/two_body_rdm/all_states_routines.irp.f index b8888299..3084dd5b 100644 --- a/src/two_body_rdm/all_states_routines.irp.f +++ b/src/two_body_rdm/all_states_routines.irp.f @@ -244,12 +244,12 @@ subroutine orb_range_all_states_two_rdm_openmp_work_$N_int(big_array,dim1,norb,l tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) c_contrib = 0.d0 - do l= 1, N_states + do l= 1, N_st c_1(l) = u_t(l,l_a) c_2(l) = u_t(l,k_a) c_contrib(l) = c_1(l) * c_2(l) enddo - call orb_range_off_diagonal_double_to_two_rdm_ab_dm(tmp_det,tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + call orb_range_off_diagonal_double_to_two_rdm_ab_dm_all_states(tmp_det,tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) enddo endif @@ -319,16 +319,16 @@ subroutine orb_range_all_states_two_rdm_openmp_work_$N_int(big_array,dim1,norb,l tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) c_contrib = 0.d0 - do l= 1, N_states + do l= 1, N_st c_1(l) = u_t(l,l_a) c_2(l) = u_t(l,k_a) c_contrib(l) = c_1(l) * c_2(l) enddo if(alpha_beta.or.spin_trace.or.alpha_alpha)then ! increment the alpha/beta part for single excitations - call orb_range_off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + call orb_range_off_diagonal_single_to_two_rdm_ab_dm_all_states(tmp_det, tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) ! increment the alpha/alpha part for single excitations - call orb_range_off_diagonal_single_to_two_rdm_aa_dm(tmp_det,tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + call orb_range_off_diagonal_single_to_two_rdm_aa_dm_all_states(tmp_det,tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) endif enddo @@ -346,12 +346,12 @@ subroutine orb_range_all_states_two_rdm_openmp_work_$N_int(big_array,dim1,norb,l ASSERT (lrow <= N_det_alpha_unique) c_contrib = 0.d0 - do l= 1, N_states + do l= 1, N_st c_1(l) = u_t(l,l_a) c_2(l) = u_t(l,k_a) c_contrib(l) += c_1(l) * c_2(l) enddo - call orb_range_off_diagonal_double_to_two_rdm_aa_dm(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + call orb_range_off_diagonal_double_to_two_rdm_aa_dm_all_states(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) enddo endif @@ -411,16 +411,16 @@ subroutine orb_range_all_states_two_rdm_openmp_work_$N_int(big_array,dim1,norb,l tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol) l_a = psi_bilinear_matrix_transp_order(l_b) c_contrib = 0.d0 - do l= 1, N_states + do l= 1, N_st c_1(l) = u_t(l,l_a) c_2(l) = u_t(l,k_a) c_contrib(l) = c_1(l) * c_2(l) enddo if(alpha_beta.or.spin_trace.or.beta_beta)then ! increment the alpha/beta part for single excitations - call orb_range_off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + call orb_range_off_diagonal_single_to_two_rdm_ab_dm_all_states(tmp_det, tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) ! increment the beta /beta part for single excitations - call orb_range_off_diagonal_single_to_two_rdm_bb_dm(tmp_det, tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + call orb_range_off_diagonal_single_to_two_rdm_bb_dm_all_states(tmp_det, tmp_det2,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) endif enddo @@ -437,12 +437,12 @@ subroutine orb_range_all_states_two_rdm_openmp_work_$N_int(big_array,dim1,norb,l l_a = psi_bilinear_matrix_transp_order(l_b) c_contrib = 0.d0 - do l= 1, N_states + do l= 1, N_st c_1(l) = u_t(l,l_a) c_2(l) = u_t(l,k_a) c_contrib(l) = c_1(l) * c_2(l) enddo - call orb_range_off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_alpha_unique(1, lcol),c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + call orb_range_off_diagonal_double_to_two_rdm_bb_dm_all_states(tmp_det(1,2),psi_det_alpha_unique(1, lcol),c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) ASSERT (l_a <= N_det) enddo @@ -469,12 +469,12 @@ subroutine orb_range_all_states_two_rdm_openmp_work_$N_int(big_array,dim1,norb,l double precision :: c_1(N_states),c_2(N_states) c_contrib = 0.d0 - do l = 1, N_states + do l = 1, N_st c_1(l) = u_t(l,k_a) - c_contrib(l) += c_1(l) * c_1(l) + c_contrib(l) = c_1(l) * c_1(l) enddo - call orb_range_diagonal_contrib_to_all_two_rdm_dm(tmp_det,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + call orb_range_diagonal_contrib_to_all_two_rdm_dm_all_states(tmp_det,c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) end do !!$OMP END DO From e69b2d6b25bfdebdd57e76a5248abe449acffbb2 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 2 Jul 2019 10:20:20 +0200 Subject: [PATCH 31/59] Cleaning in bitmasks --- src/bitmask/bitmasks.irp.f | 817 +++++++++++++------------- src/bitmask/core_inact_act_virt.irp.f | 586 ++++++++++-------- src/casscf/bielec.irp.f | 24 +- 3 files changed, 766 insertions(+), 661 deletions(-) diff --git a/src/bitmask/bitmasks.irp.f b/src/bitmask/bitmasks.irp.f index d425dda6..bbcff63c 100644 --- a/src/bitmask/bitmasks.irp.f +++ b/src/bitmask/bitmasks.irp.f @@ -11,7 +11,7 @@ BEGIN_PROVIDER [ integer, N_int ] if (N_int > N_int_max) then stop 'N_int > N_int_max' endif - + END_PROVIDER @@ -20,7 +20,7 @@ BEGIN_PROVIDER [ integer(bit_kind), full_ijkl_bitmask, (N_int) ] BEGIN_DOC ! Bitmask to include all possible MOs END_DOC - + integer :: i,j,k k=0 do j=1,N_int @@ -37,34 +37,34 @@ END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), full_ijkl_bitmask_4, (N_int,4) ] implicit none - integer :: i + integer :: i do i=1,N_int - full_ijkl_bitmask_4(i,1) = full_ijkl_bitmask(i) - full_ijkl_bitmask_4(i,2) = full_ijkl_bitmask(i) - full_ijkl_bitmask_4(i,3) = full_ijkl_bitmask(i) - full_ijkl_bitmask_4(i,4) = full_ijkl_bitmask(i) + full_ijkl_bitmask_4(i,1) = full_ijkl_bitmask(i) + full_ijkl_bitmask_4(i,2) = full_ijkl_bitmask(i) + full_ijkl_bitmask_4(i,3) = full_ijkl_bitmask(i) + full_ijkl_bitmask_4(i,4) = full_ijkl_bitmask(i) enddo END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), core_inact_act_bitmask_4, (N_int,4) ] implicit none - integer :: i + integer :: i do i=1,N_int - core_inact_act_bitmask_4(i,1) = reunion_of_core_inact_act_bitmask(i,1) - core_inact_act_bitmask_4(i,2) = reunion_of_core_inact_act_bitmask(i,1) - core_inact_act_bitmask_4(i,3) = reunion_of_core_inact_act_bitmask(i,1) - core_inact_act_bitmask_4(i,4) = reunion_of_core_inact_act_bitmask(i,1) + core_inact_act_bitmask_4(i,1) = reunion_of_core_inact_act_bitmask(i,1) + core_inact_act_bitmask_4(i,2) = reunion_of_core_inact_act_bitmask(i,1) + core_inact_act_bitmask_4(i,3) = reunion_of_core_inact_act_bitmask(i,1) + core_inact_act_bitmask_4(i,4) = reunion_of_core_inact_act_bitmask(i,1) enddo END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), virt_bitmask_4, (N_int,4) ] implicit none - integer :: i + integer :: i do i=1,N_int - virt_bitmask_4(i,1) = virt_bitmask(i,1) - virt_bitmask_4(i,2) = virt_bitmask(i,1) - virt_bitmask_4(i,3) = virt_bitmask(i,1) - virt_bitmask_4(i,4) = virt_bitmask(i,1) + virt_bitmask_4(i,1) = virt_bitmask(i,1) + virt_bitmask_4(i,2) = virt_bitmask(i,1) + virt_bitmask_4(i,3) = virt_bitmask(i,1) + virt_bitmask_4(i,4) = virt_bitmask(i,1) enddo END_PROVIDER @@ -78,491 +78,480 @@ BEGIN_PROVIDER [ integer(bit_kind), HF_bitmask, (N_int,2)] END_DOC integer :: i,j,n integer :: occ(elec_alpha_num) - + HF_bitmask = 0_bit_kind do i=1,elec_alpha_num - occ(i) = i + occ(i) = i enddo call list_to_bitstring( HF_bitmask(1,1), occ, elec_alpha_num, N_int) ! elec_alpha_num <= elec_beta_num, so occ is already OK. call list_to_bitstring( HF_bitmask(1,2), occ, elec_beta_num, N_int) - + END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), ref_bitmask, (N_int,2)] - implicit none - BEGIN_DOC -! Reference bit mask, used in Slater rules, chosen as Hartree-Fock bitmask - END_DOC - ref_bitmask = HF_bitmask + implicit none + BEGIN_DOC + ! Reference bit mask, used in Slater rules, chosen as Hartree-Fock bitmask + END_DOC + ref_bitmask = HF_bitmask END_PROVIDER BEGIN_PROVIDER [ integer, N_generators_bitmask ] - implicit none - BEGIN_DOC - ! Number of bitmasks for generators - END_DOC - logical :: exists - PROVIDE ezfio_filename N_int - - if (mpi_master) then - call ezfio_has_bitmasks_N_mask_gen(exists) - if (exists) then - call ezfio_get_bitmasks_N_mask_gen(N_generators_bitmask) - integer :: N_int_check - integer :: bit_kind_check - call ezfio_get_bitmasks_bit_kind(bit_kind_check) - if (bit_kind_check /= bit_kind) then - print *, bit_kind_check, bit_kind - print *, 'Error: bit_kind is not correct in EZFIO file' + implicit none + BEGIN_DOC + ! Number of bitmasks for generators + END_DOC + logical :: exists + PROVIDE ezfio_filename N_int + + if (mpi_master) then + call ezfio_has_bitmasks_N_mask_gen(exists) + if (exists) then + call ezfio_get_bitmasks_N_mask_gen(N_generators_bitmask) + integer :: N_int_check + integer :: bit_kind_check + call ezfio_get_bitmasks_bit_kind(bit_kind_check) + if (bit_kind_check /= bit_kind) then + print *, bit_kind_check, bit_kind + print *, 'Error: bit_kind is not correct in EZFIO file' + endif + call ezfio_get_bitmasks_N_int(N_int_check) + if (N_int_check /= N_int) then + print *, N_int_check, N_int + print *, 'Error: N_int is not correct in EZFIO file' + endif + else + N_generators_bitmask = 1 endif - call ezfio_get_bitmasks_N_int(N_int_check) - if (N_int_check /= N_int) then - print *, N_int_check, N_int - print *, 'Error: N_int is not correct in EZFIO file' - endif - else - N_generators_bitmask = 1 + ASSERT (N_generators_bitmask > 0) + call write_int(6,N_generators_bitmask,'N_generators_bitmask') endif - ASSERT (N_generators_bitmask > 0) - call write_int(6,N_generators_bitmask,'N_generators_bitmask') - endif IRP_IF MPI_DEBUG - print *, irp_here, mpi_rank - call MPI_BARRIER(MPI_COMM_WORLD, ierr) + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) IRP_ENDIF IRP_IF MPI - include 'mpif.h' - integer :: ierr - call MPI_BCAST( N_generators_bitmask, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - stop 'Unable to read N_generators_bitmask with MPI' - endif + include 'mpif.h' + integer :: ierr + call MPI_BCAST( N_generators_bitmask, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read N_generators_bitmask with MPI' + endif IRP_ENDIF - - + + END_PROVIDER BEGIN_PROVIDER [ integer, N_generators_bitmask_restart ] - implicit none - BEGIN_DOC - ! Number of bitmasks for generators - END_DOC - logical :: exists - PROVIDE ezfio_filename N_int - - if (mpi_master) then - call ezfio_has_bitmasks_N_mask_gen(exists) - if (exists) then - call ezfio_get_bitmasks_N_mask_gen(N_generators_bitmask_restart) - integer :: N_int_check - integer :: bit_kind_check - call ezfio_get_bitmasks_bit_kind(bit_kind_check) - if (bit_kind_check /= bit_kind) then - print *, bit_kind_check, bit_kind - print *, 'Error: bit_kind is not correct in EZFIO file' + implicit none + BEGIN_DOC + ! Number of bitmasks for generators + END_DOC + logical :: exists + PROVIDE ezfio_filename N_int + + if (mpi_master) then + call ezfio_has_bitmasks_N_mask_gen(exists) + if (exists) then + call ezfio_get_bitmasks_N_mask_gen(N_generators_bitmask_restart) + integer :: N_int_check + integer :: bit_kind_check + call ezfio_get_bitmasks_bit_kind(bit_kind_check) + if (bit_kind_check /= bit_kind) then + print *, bit_kind_check, bit_kind + print *, 'Error: bit_kind is not correct in EZFIO file' + endif + call ezfio_get_bitmasks_N_int(N_int_check) + if (N_int_check /= N_int) then + print *, N_int_check, N_int + print *, 'Error: N_int is not correct in EZFIO file' + endif + else + N_generators_bitmask_restart = 1 endif - call ezfio_get_bitmasks_N_int(N_int_check) - if (N_int_check /= N_int) then - print *, N_int_check, N_int - print *, 'Error: N_int is not correct in EZFIO file' - endif - else - N_generators_bitmask_restart = 1 + ASSERT (N_generators_bitmask_restart > 0) + call write_int(6,N_generators_bitmask_restart,'N_generators_bitmask_restart') endif - ASSERT (N_generators_bitmask_restart > 0) - call write_int(6,N_generators_bitmask_restart,'N_generators_bitmask_restart') - endif IRP_IF MPI_DEBUG - print *, irp_here, mpi_rank - call MPI_BARRIER(MPI_COMM_WORLD, ierr) + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) IRP_ENDIF - IRP_IF MPI - include 'mpif.h' - integer :: ierr - call MPI_BCAST( N_generators_bitmask_restart, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - stop 'Unable to read N_generators_bitmask_restart with MPI' - endif - IRP_ENDIF - - + IRP_IF MPI + include 'mpif.h' + integer :: ierr + call MPI_BCAST( N_generators_bitmask_restart, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read N_generators_bitmask_restart with MPI' + endif + IRP_ENDIF + + END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), generators_bitmask_restart, (N_int,2,6,N_generators_bitmask_restart) ] - implicit none - BEGIN_DOC - ! Bitmasks for generator determinants. - ! (N_int, alpha/beta, hole/particle, generator). - ! - ! 3rd index is : - ! - ! * 1 : hole for single exc - ! - ! * 2 : particle for single exc - ! - ! * 3 : hole for 1st exc of double - ! - ! * 4 : particle for 1st exc of double - ! - ! * 5 : hole for 2nd exc of double - ! - ! * 6 : particle for 2nd exc of double - ! - END_DOC - logical :: exists - PROVIDE ezfio_filename full_ijkl_bitmask N_generators_bitmask N_int - PROVIDE generators_bitmask_restart - - if (mpi_master) then - call ezfio_has_bitmasks_generators(exists) - if (exists) then - call ezfio_get_bitmasks_generators(generators_bitmask_restart) - else - integer :: k, ispin + implicit none + BEGIN_DOC + ! Bitmasks for generator determinants. + ! (N_int, alpha/beta, hole/particle, generator). + ! + ! 3rd index is : + ! + ! * 1 : hole for single exc + ! + ! * 2 : particle for single exc + ! + ! * 3 : hole for 1st exc of double + ! + ! * 4 : particle for 1st exc of double + ! + ! * 5 : hole for 2nd exc of double + ! + ! * 6 : particle for 2nd exc of double + ! + END_DOC + logical :: exists + PROVIDE ezfio_filename full_ijkl_bitmask N_generators_bitmask N_int + PROVIDE generators_bitmask_restart + + if (mpi_master) then + call ezfio_has_bitmasks_generators(exists) + if (exists) then + call ezfio_get_bitmasks_generators(generators_bitmask_restart) + else + integer :: k, ispin + do k=1,N_generators_bitmask + do ispin=1,2 + do i=1,N_int + generators_bitmask_restart(i,ispin,s_hole ,k) = full_ijkl_bitmask(i) + generators_bitmask_restart(i,ispin,s_part ,k) = full_ijkl_bitmask(i) + generators_bitmask_restart(i,ispin,d_hole1,k) = full_ijkl_bitmask(i) + generators_bitmask_restart(i,ispin,d_part1,k) = full_ijkl_bitmask(i) + generators_bitmask_restart(i,ispin,d_hole2,k) = full_ijkl_bitmask(i) + generators_bitmask_restart(i,ispin,d_part2,k) = full_ijkl_bitmask(i) + enddo + enddo + enddo + endif + + integer :: i do k=1,N_generators_bitmask do ispin=1,2 do i=1,N_int - generators_bitmask_restart(i,ispin,s_hole ,k) = full_ijkl_bitmask(i) - generators_bitmask_restart(i,ispin,s_part ,k) = full_ijkl_bitmask(i) - generators_bitmask_restart(i,ispin,d_hole1,k) = full_ijkl_bitmask(i) - generators_bitmask_restart(i,ispin,d_part1,k) = full_ijkl_bitmask(i) - generators_bitmask_restart(i,ispin,d_hole2,k) = full_ijkl_bitmask(i) - generators_bitmask_restart(i,ispin,d_part2,k) = full_ijkl_bitmask(i) + generators_bitmask_restart(i,ispin,s_hole ,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,s_hole,k) ) + generators_bitmask_restart(i,ispin,s_part ,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,s_part,k) ) + generators_bitmask_restart(i,ispin,d_hole1,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,d_hole1,k) ) + generators_bitmask_restart(i,ispin,d_part1,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,d_part1,k) ) + generators_bitmask_restart(i,ispin,d_hole2,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,d_hole2,k) ) + generators_bitmask_restart(i,ispin,d_part2,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,d_part2,k) ) enddo enddo enddo endif - - integer :: i - do k=1,N_generators_bitmask - do ispin=1,2 - do i=1,N_int - generators_bitmask_restart(i,ispin,s_hole ,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,s_hole,k) ) - generators_bitmask_restart(i,ispin,s_part ,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,s_part,k) ) - generators_bitmask_restart(i,ispin,d_hole1,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,d_hole1,k) ) - generators_bitmask_restart(i,ispin,d_part1,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,d_part1,k) ) - generators_bitmask_restart(i,ispin,d_hole2,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,d_hole2,k) ) - generators_bitmask_restart(i,ispin,d_part2,k) = iand(full_ijkl_bitmask(i),generators_bitmask_restart(i,ispin,d_part2,k) ) - enddo - enddo - enddo - endif IRP_IF MPI_DEBUG - print *, irp_here, mpi_rank - call MPI_BARRIER(MPI_COMM_WORLD, ierr) + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) IRP_ENDIF IRP_IF MPI - include 'mpif.h' - integer :: ierr - call MPI_BCAST( generators_bitmask_restart, N_int*2*6*N_generators_bitmask_restart, MPI_BIT_KIND, 0, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - stop 'Unable to read generators_bitmask_restart with MPI' - endif + include 'mpif.h' + integer :: ierr + call MPI_BCAST( generators_bitmask_restart, N_int*2*6*N_generators_bitmask_restart, MPI_BIT_KIND, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read generators_bitmask_restart with MPI' + endif IRP_ENDIF - + END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), generators_bitmask, (N_int,2,6,N_generators_bitmask) ] - implicit none - BEGIN_DOC - ! Bitmasks for generator determinants. - ! (N_int, alpha/beta, hole/particle, generator). - ! - ! 3rd index is : - ! - ! * 1 : hole for single exc - ! - ! * 2 : particle for single exc - ! - ! * 3 : hole for 1st exc of double - ! - ! * 4 : particle for 1st exc of double - ! - ! * 5 : hole for 2nd exc of double - ! - ! * 6 : particle for 2nd exc of double - ! - END_DOC - logical :: exists - PROVIDE ezfio_filename full_ijkl_bitmask N_generators_bitmask - -if (mpi_master) then - call ezfio_has_bitmasks_generators(exists) - if (exists) then - call ezfio_get_bitmasks_generators(generators_bitmask) - else - integer :: k, ispin, i - do k=1,N_generators_bitmask - do ispin=1,2 - do i=1,N_int - generators_bitmask(i,ispin,s_hole ,k) = full_ijkl_bitmask(i) - generators_bitmask(i,ispin,s_part ,k) = full_ijkl_bitmask(i) - generators_bitmask(i,ispin,d_hole1,k) = full_ijkl_bitmask(i) - generators_bitmask(i,ispin,d_part1,k) = full_ijkl_bitmask(i) - generators_bitmask(i,ispin,d_hole2,k) = full_ijkl_bitmask(i) - generators_bitmask(i,ispin,d_part2,k) = full_ijkl_bitmask(i) + implicit none + BEGIN_DOC + ! Bitmasks for generator determinants. + ! (N_int, alpha/beta, hole/particle, generator). + ! + ! 3rd index is : + ! + ! * 1 : hole for single exc + ! + ! * 2 : particle for single exc + ! + ! * 3 : hole for 1st exc of double + ! + ! * 4 : particle for 1st exc of double + ! + ! * 5 : hole for 2nd exc of double + ! + ! * 6 : particle for 2nd exc of double + ! + END_DOC + logical :: exists + PROVIDE ezfio_filename full_ijkl_bitmask N_generators_bitmask + + if (mpi_master) then + call ezfio_has_bitmasks_generators(exists) + if (exists) then + call ezfio_get_bitmasks_generators(generators_bitmask) + else + integer :: k, ispin, i + do k=1,N_generators_bitmask + do ispin=1,2 + do i=1,N_int + generators_bitmask(i,ispin,s_hole ,k) = full_ijkl_bitmask(i) + generators_bitmask(i,ispin,s_part ,k) = full_ijkl_bitmask(i) + generators_bitmask(i,ispin,d_hole1,k) = full_ijkl_bitmask(i) + generators_bitmask(i,ispin,d_part1,k) = full_ijkl_bitmask(i) + generators_bitmask(i,ispin,d_hole2,k) = full_ijkl_bitmask(i) + generators_bitmask(i,ispin,d_part2,k) = full_ijkl_bitmask(i) + enddo + enddo enddo - enddo - enddo - endif - - do k=1,N_generators_bitmask - do ispin=1,2 - do i=1,N_int - generators_bitmask(i,ispin,s_hole ,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,s_hole,k) ) - generators_bitmask(i,ispin,s_part ,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,s_part,k) ) - generators_bitmask(i,ispin,d_hole1,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_hole1,k) ) - generators_bitmask(i,ispin,d_part1,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_part1,k) ) - generators_bitmask(i,ispin,d_hole2,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_hole2,k) ) - generators_bitmask(i,ispin,d_part2,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_part2,k) ) - enddo - enddo - enddo - endif + endif + + do k=1,N_generators_bitmask + do ispin=1,2 + do i=1,N_int + generators_bitmask(i,ispin,s_hole ,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,s_hole,k) ) + generators_bitmask(i,ispin,s_part ,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,s_part,k) ) + generators_bitmask(i,ispin,d_hole1,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_hole1,k) ) + generators_bitmask(i,ispin,d_part1,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_part1,k) ) + generators_bitmask(i,ispin,d_hole2,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_hole2,k) ) + generators_bitmask(i,ispin,d_part2,k) = iand(full_ijkl_bitmask(i),generators_bitmask(i,ispin,d_part2,k) ) + enddo + enddo + enddo + endif IRP_IF MPI_DEBUG - print *, irp_here, mpi_rank - call MPI_BARRIER(MPI_COMM_WORLD, ierr) + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) IRP_ENDIF IRP_IF MPI - include 'mpif.h' - integer :: ierr - call MPI_BCAST( generators_bitmask, N_int*2*6*N_generators_bitmask, MPI_BIT_KIND, 0, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - stop 'Unable to read generators_bitmask with MPI' - endif + include 'mpif.h' + integer :: ierr + call MPI_BCAST( generators_bitmask, N_int*2*6*N_generators_bitmask, MPI_BIT_KIND, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read generators_bitmask with MPI' + endif IRP_ENDIF - + END_PROVIDER BEGIN_PROVIDER [ integer, N_cas_bitmask ] - implicit none - BEGIN_DOC - ! Number of bitmasks for CAS - END_DOC - logical :: exists - PROVIDE ezfio_filename - PROVIDE N_cas_bitmask N_int - if (mpi_master) then - call ezfio_has_bitmasks_N_mask_cas(exists) - if (exists) then - call ezfio_get_bitmasks_N_mask_cas(N_cas_bitmask) - integer :: N_int_check - integer :: bit_kind_check - call ezfio_get_bitmasks_bit_kind(bit_kind_check) - if (bit_kind_check /= bit_kind) then - print *, bit_kind_check, bit_kind - print *, 'Error: bit_kind is not correct in EZFIO file' + implicit none + BEGIN_DOC + ! Number of bitmasks for CAS + END_DOC + logical :: exists + PROVIDE ezfio_filename + PROVIDE N_cas_bitmask N_int + if (mpi_master) then + call ezfio_has_bitmasks_N_mask_cas(exists) + if (exists) then + call ezfio_get_bitmasks_N_mask_cas(N_cas_bitmask) + integer :: N_int_check + integer :: bit_kind_check + call ezfio_get_bitmasks_bit_kind(bit_kind_check) + if (bit_kind_check /= bit_kind) then + print *, bit_kind_check, bit_kind + print *, 'Error: bit_kind is not correct in EZFIO file' + endif + call ezfio_get_bitmasks_N_int(N_int_check) + if (N_int_check /= N_int) then + print *, N_int_check, N_int + print *, 'Error: N_int is not correct in EZFIO file' + endif + else + N_cas_bitmask = 1 endif - call ezfio_get_bitmasks_N_int(N_int_check) - if (N_int_check /= N_int) then - print *, N_int_check, N_int - print *, 'Error: N_int is not correct in EZFIO file' - endif - else - N_cas_bitmask = 1 + call write_int(6,N_cas_bitmask,'N_cas_bitmask') endif - call write_int(6,N_cas_bitmask,'N_cas_bitmask') - endif - ASSERT (N_cas_bitmask > 0) + ASSERT (N_cas_bitmask > 0) IRP_IF MPI_DEBUG - print *, irp_here, mpi_rank - call MPI_BARRIER(MPI_COMM_WORLD, ierr) + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) IRP_ENDIF IRP_IF MPI - include 'mpif.h' - integer :: ierr - call MPI_BCAST( N_cas_bitmask, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - stop 'Unable to read N_cas_bitmask with MPI' - endif + include 'mpif.h' + integer :: ierr + call MPI_BCAST( N_cas_bitmask, 1, MPI_INTEGER, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read N_cas_bitmask with MPI' + endif IRP_ENDIF - + END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), cas_bitmask, (N_int,2,N_cas_bitmask) ] - implicit none - BEGIN_DOC - ! Bitmasks for CAS reference determinants. (N_int, alpha/beta, CAS reference) - END_DOC - logical :: exists - integer :: i,i_part,i_gen,j,k - PROVIDE ezfio_filename generators_bitmask_restart full_ijkl_bitmask - PROVIDE n_generators_bitmask HF_bitmask - - if (mpi_master) then - call ezfio_has_bitmasks_cas(exists) - if (exists) then - call ezfio_get_bitmasks_cas(cas_bitmask) - else - if(N_generators_bitmask == 1)then - do j=1, N_cas_bitmask - do i=1, N_int - cas_bitmask(i,1,j) = iand(not(HF_bitmask(i,1)),full_ijkl_bitmask(i)) - cas_bitmask(i,2,j) = iand(not(HF_bitmask(i,2)),full_ijkl_bitmask(i)) - enddo - enddo + implicit none + BEGIN_DOC + ! Bitmasks for CAS reference determinants. (N_int, alpha/beta, CAS reference) + END_DOC + logical :: exists + integer :: i,i_part,i_gen,j,k + PROVIDE ezfio_filename generators_bitmask_restart full_ijkl_bitmask + PROVIDE n_generators_bitmask HF_bitmask + + if (mpi_master) then + call ezfio_has_bitmasks_cas(exists) + if (exists) then + call ezfio_get_bitmasks_cas(cas_bitmask) else - i_part = 2 - i_gen = 1 - do j=1, N_cas_bitmask - do i=1, N_int - cas_bitmask(i,1,j) = generators_bitmask_restart(i,1,i_part,i_gen) - cas_bitmask(i,2,j) = generators_bitmask_restart(i,2,i_part,i_gen) - enddo - enddo + if(N_generators_bitmask == 1)then + do j=1, N_cas_bitmask + do i=1, N_int + cas_bitmask(i,1,j) = iand(not(HF_bitmask(i,1)),full_ijkl_bitmask(i)) + cas_bitmask(i,2,j) = iand(not(HF_bitmask(i,2)),full_ijkl_bitmask(i)) + enddo + enddo + else + i_part = 2 + i_gen = 1 + do j=1, N_cas_bitmask + do i=1, N_int + cas_bitmask(i,1,j) = generators_bitmask_restart(i,1,i_part,i_gen) + cas_bitmask(i,2,j) = generators_bitmask_restart(i,2,i_part,i_gen) + enddo + enddo + endif endif - endif - do i=1,N_cas_bitmask - do j = 1, N_cas_bitmask - do k=1,N_int - cas_bitmask(k,j,i) = iand(cas_bitmask(k,j,i),full_ijkl_bitmask(k)) + do i=1,N_cas_bitmask + do j = 1, N_cas_bitmask + do k=1,N_int + cas_bitmask(k,j,i) = iand(cas_bitmask(k,j,i),full_ijkl_bitmask(k)) + enddo enddo enddo - enddo - write(*,*) 'Read CAS bitmask' - endif + write(*,*) 'Read CAS bitmask' + endif IRP_IF MPI_DEBUG - print *, irp_here, mpi_rank - call MPI_BARRIER(MPI_COMM_WORLD, ierr) + print *, irp_here, mpi_rank + call MPI_BARRIER(MPI_COMM_WORLD, ierr) IRP_ENDIF IRP_IF MPI - include 'mpif.h' - integer :: ierr - call MPI_BCAST( cas_bitmask, N_int*2*N_cas_bitmask, MPI_BIT_KIND, 0, MPI_COMM_WORLD, ierr) - if (ierr /= MPI_SUCCESS) then - stop 'Unable to read cas_bitmask with MPI' - endif + include 'mpif.h' + integer :: ierr + call MPI_BCAST( cas_bitmask, N_int*2*N_cas_bitmask, MPI_BIT_KIND, 0, MPI_COMM_WORLD, ierr) + if (ierr /= MPI_SUCCESS) then + stop 'Unable to read cas_bitmask with MPI' + endif IRP_ENDIF - - + + END_PROVIDER - BEGIN_PROVIDER [ integer, n_core_inact_orb ] - implicit none - integer :: i - n_core_inact_orb = 0 - do i = 1, N_int - n_core_inact_orb += popcnt(reunion_of_core_inact_bitmask(i,1)) - enddo - ENd_PROVIDER - - BEGIN_PROVIDER [ integer(bit_kind), reunion_of_core_inact_bitmask, (N_int,2)] - implicit none - BEGIN_DOC - ! Reunion of the core and inactive and virtual bitmasks - END_DOC - integer :: i - do i = 1, N_int - reunion_of_core_inact_bitmask(i,1) = ior(core_bitmask(i,1),inact_bitmask(i,1)) - reunion_of_core_inact_bitmask(i,2) = ior(core_bitmask(i,2),inact_bitmask(i,2)) - enddo - END_PROVIDER +BEGIN_PROVIDER [ integer(bit_kind), reunion_of_core_inact_bitmask, (N_int,2)] + implicit none + BEGIN_DOC + ! Reunion of the core and inactive and virtual bitmasks + END_DOC + integer :: i + do i = 1, N_int + reunion_of_core_inact_bitmask(i,1) = ior(core_bitmask(i,1),inact_bitmask(i,1)) + reunion_of_core_inact_bitmask(i,2) = ior(core_bitmask(i,2),inact_bitmask(i,2)) + enddo +END_PROVIDER - BEGIN_PROVIDER [integer(bit_kind), reunion_of_core_inact_act_bitmask, (N_int,2)] - implicit none - BEGIN_DOC - ! Reunion of the core, inactive and active bitmasks - END_DOC - integer :: i,j - - do i = 1, N_int - reunion_of_core_inact_act_bitmask(i,1) = ior(reunion_of_core_inact_bitmask(i,1),act_bitmask(i,1)) - reunion_of_core_inact_act_bitmask(i,2) = ior(reunion_of_core_inact_bitmask(i,2),act_bitmask(i,2)) - enddo - END_PROVIDER +BEGIN_PROVIDER [integer(bit_kind), reunion_of_inact_act_bitmask, (N_int,2)] + implicit none + BEGIN_DOC + ! Reunion of the inactive and active bitmasks + END_DOC + integer :: i,j + + do i = 1, N_int + reunion_of_inact_act_bitmask(i,1) = ior(inact_bitmask(i,1),act_bitmask(i,1)) + reunion_of_inact_act_bitmask(i,2) = ior(inact_bitmask(i,2),act_bitmask(i,2)) + enddo +END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), reunion_of_bitmask, (N_int,2)] - implicit none - BEGIN_DOC - ! Reunion of the inactive, active and virtual bitmasks - END_DOC - integer :: i,j - do i = 1, N_int - reunion_of_bitmask(i,1) = ior(ior(cas_bitmask(i,1,1),inact_bitmask(i,1)),virt_bitmask(i,1)) - reunion_of_bitmask(i,2) = ior(ior(cas_bitmask(i,2,1),inact_bitmask(i,2)),virt_bitmask(i,2)) - enddo - END_PROVIDER +BEGIN_PROVIDER [integer(bit_kind), reunion_of_core_inact_act_bitmask, (N_int,2)] + implicit none + BEGIN_DOC + ! Reunion of the core, inactive and active bitmasks + END_DOC + integer :: i,j + + do i = 1, N_int + reunion_of_core_inact_act_bitmask(i,1) = ior(reunion_of_core_inact_bitmask(i,1),act_bitmask(i,1)) + reunion_of_core_inact_act_bitmask(i,2) = ior(reunion_of_core_inact_bitmask(i,2),act_bitmask(i,2)) + enddo +END_PROVIDER + + +BEGIN_PROVIDER [ integer(bit_kind), reunion_of_bitmask, (N_int,2)] + implicit none + BEGIN_DOC + ! Reunion of the inactive, active and virtual bitmasks + END_DOC + integer :: i,j + do i = 1, N_int + reunion_of_bitmask(i,1) = ior(ior(cas_bitmask(i,1,1),inact_bitmask(i,1)),virt_bitmask(i,1)) + reunion_of_bitmask(i,2) = ior(ior(cas_bitmask(i,2,1),inact_bitmask(i,2)),virt_bitmask(i,2)) + enddo +END_PROVIDER BEGIN_PROVIDER [ integer(bit_kind), inact_virt_bitmask, (N_int,2)] &BEGIN_PROVIDER [ integer(bit_kind), core_inact_virt_bitmask, (N_int,2)] - implicit none - BEGIN_DOC - ! Reunion of the inactive and virtual bitmasks - END_DOC - integer :: i,j - do i = 1, N_int - inact_virt_bitmask(i,1) = ior(inact_bitmask(i,1),virt_bitmask(i,1)) - inact_virt_bitmask(i,2) = ior(inact_bitmask(i,2),virt_bitmask(i,2)) - core_inact_virt_bitmask(i,1) = ior(core_bitmask(i,1),inact_virt_bitmask(i,1)) - core_inact_virt_bitmask(i,2) = ior(core_bitmask(i,2),inact_virt_bitmask(i,2)) - enddo - END_PROVIDER + implicit none + BEGIN_DOC + ! Reunion of the inactive and virtual bitmasks + END_DOC + integer :: i,j + do i = 1, N_int + inact_virt_bitmask(i,1) = ior(inact_bitmask(i,1),virt_bitmask(i,1)) + inact_virt_bitmask(i,2) = ior(inact_bitmask(i,2),virt_bitmask(i,2)) + core_inact_virt_bitmask(i,1) = ior(core_bitmask(i,1),inact_virt_bitmask(i,1)) + core_inact_virt_bitmask(i,2) = ior(core_bitmask(i,2),inact_virt_bitmask(i,2)) + enddo +END_PROVIDER BEGIN_PROVIDER [ integer, i_bitmask_gen ] - implicit none - BEGIN_DOC - ! Current bitmask for the generators - END_DOC - i_bitmask_gen = 1 + implicit none + BEGIN_DOC + ! Current bitmask for the generators + END_DOC + i_bitmask_gen = 1 END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), unpaired_alpha_electrons, (N_int)] - implicit none - BEGIN_DOC - ! Bitmask reprenting the unpaired alpha electrons in the HF_bitmask - END_DOC - integer :: i - unpaired_alpha_electrons = 0_bit_kind - do i = 1, N_int - unpaired_alpha_electrons(i) = xor(HF_bitmask(i,1),HF_bitmask(i,2)) - enddo - END_PROVIDER +BEGIN_PROVIDER [ integer(bit_kind), unpaired_alpha_electrons, (N_int)] + implicit none + BEGIN_DOC + ! Bitmask reprenting the unpaired alpha electrons in the HF_bitmask + END_DOC + integer :: i + unpaired_alpha_electrons = 0_bit_kind + do i = 1, N_int + unpaired_alpha_electrons(i) = xor(HF_bitmask(i,1),HF_bitmask(i,2)) + enddo +END_PROVIDER - BEGIN_PROVIDER [integer(bit_kind), closed_shell_ref_bitmask, (N_int,2)] - implicit none - integer :: i,j - do i = 1, N_int - closed_shell_ref_bitmask(i,1) = ior(ref_bitmask(i,1),cas_bitmask(i,1,1)) - closed_shell_ref_bitmask(i,2) = ior(ref_bitmask(i,2),cas_bitmask(i,2,1)) - enddo - END_PROVIDER +BEGIN_PROVIDER [integer(bit_kind), closed_shell_ref_bitmask, (N_int,2)] + implicit none + integer :: i,j + do i = 1, N_int + closed_shell_ref_bitmask(i,1) = ior(ref_bitmask(i,1),cas_bitmask(i,1,1)) + closed_shell_ref_bitmask(i,2) = ior(ref_bitmask(i,2),cas_bitmask(i,2,1)) + enddo +END_PROVIDER - BEGIN_PROVIDER [ integer(bit_kind), reunion_of_cas_inact_bitmask, (N_int,2)] - implicit none - BEGIN_DOC - ! Reunion of the inactive, active and virtual bitmasks - END_DOC - integer :: i,j - do i = 1, N_int - reunion_of_cas_inact_bitmask(i,1) = ior(act_bitmask(i,1),inact_bitmask(i,1)) - reunion_of_cas_inact_bitmask(i,2) = ior(act_bitmask(i,2),inact_bitmask(i,2)) - enddo - END_PROVIDER - - - BEGIN_PROVIDER [integer, n_core_orb_allocate] - implicit none - n_core_orb_allocate = max(n_core_orb,1) - END_PROVIDER - - BEGIN_PROVIDER [integer, n_inact_orb_allocate] - implicit none - n_inact_orb_allocate = max(n_inact_orb,1) - END_PROVIDER - - BEGIN_PROVIDER [integer, n_virt_orb_allocate] - implicit none - n_virt_orb_allocate = max(n_virt_orb,1) - END_PROVIDER +BEGIN_PROVIDER [ integer(bit_kind), reunion_of_cas_inact_bitmask, (N_int,2)] + implicit none + BEGIN_DOC + ! Reunion of the inactive, active and virtual bitmasks + END_DOC + integer :: i,j + do i = 1, N_int + reunion_of_cas_inact_bitmask(i,1) = ior(act_bitmask(i,1),inact_bitmask(i,1)) + reunion_of_cas_inact_bitmask(i,2) = ior(act_bitmask(i,2),inact_bitmask(i,2)) + enddo +END_PROVIDER diff --git a/src/bitmask/core_inact_act_virt.irp.f b/src/bitmask/core_inact_act_virt.irp.f index 177c3df5..ae17fc67 100644 --- a/src/bitmask/core_inact_act_virt.irp.f +++ b/src/bitmask/core_inact_act_virt.irp.f @@ -1,250 +1,366 @@ use bitmasks +BEGIN_PROVIDER [ integer, n_core_orb] + implicit none + BEGIN_DOC + ! Number of core MOs + END_DOC + integer :: i + + n_core_orb = 0 + do i = 1, mo_num + if(mo_class(i) == 'Core')then + n_core_orb += 1 + endif + enddo + + call write_int(6,n_core_orb, 'Number of core MOs') + +END_PROVIDER - BEGIN_PROVIDER [ integer, n_core_orb] - &BEGIN_PROVIDER [ integer, n_inact_orb ] - &BEGIN_PROVIDER [ integer, n_act_orb] - &BEGIN_PROVIDER [ integer, n_virt_orb ] - &BEGIN_PROVIDER [ integer, n_del_orb ] - implicit none - BEGIN_DOC - ! inact_bitmask : Bitmask of the inactive orbitals which are supposed to be doubly excited - ! in post CAS methods - ! n_inact_orb : Number of inactive orbitals - ! virt_bitmask : Bitmaks of vritual orbitals which are supposed to be recieve electrons - ! in post CAS methods - ! n_virt_orb : Number of virtual orbitals - ! list_inact : List of the inactive orbitals which are supposed to be doubly excited - ! in post CAS methods - ! list_virt : List of vritual orbitals which are supposed to be recieve electrons - ! in post CAS methods - ! list_inact_reverse : reverse list of inactive orbitals - ! list_inact_reverse(i) = 0 ::> not an inactive - ! list_inact_reverse(i) = k ::> IS the kth inactive - ! list_virt_reverse : reverse list of virtual orbitals - ! list_virt_reverse(i) = 0 ::> not an virtual - ! list_virt_reverse(i) = k ::> IS the kth virtual - ! list_act(i) = index of the ith active orbital - ! - ! list_act_reverse : reverse list of active orbitals - ! list_act_reverse(i) = 0 ::> not an active - ! list_act_reverse(i) = k ::> IS the kth active orbital - END_DOC - logical :: exists - integer :: j,i +BEGIN_PROVIDER [ integer, n_inact_orb ] + implicit none + BEGIN_DOC + ! Number of inactive MOs + END_DOC + integer :: i + + n_inact_orb = 0 + do i = 1, mo_num + if (mo_class(i) == 'Inactive')then + n_inact_orb += 1 + endif + enddo + + call write_int(6,n_inact_orb,'Number of inactive MOs') + +END_PROVIDER - n_core_orb = 0 - n_inact_orb = 0 - n_act_orb = 0 - n_virt_orb = 0 - n_del_orb = 0 - do i = 1, mo_num - if(mo_class(i) == 'Core')then - n_core_orb += 1 - else if (mo_class(i) == 'Inactive')then - n_inact_orb += 1 - else if (mo_class(i) == 'Active')then - n_act_orb += 1 - else if (mo_class(i) == 'Virtual')then - n_virt_orb += 1 - else if (mo_class(i) == 'Deleted')then - n_del_orb += 1 - endif - enddo +BEGIN_PROVIDER [ integer, n_act_orb] + implicit none + BEGIN_DOC + ! Number of active MOs + END_DOC + integer :: i + + n_act_orb = 0 + do i = 1, mo_num + if (mo_class(i) == 'Active')then + n_act_orb += 1 + endif + enddo + + call write_int(6,n_act_orb, 'Number of active MOs') + +END_PROVIDER + +BEGIN_PROVIDER [ integer, n_virt_orb ] + implicit none + BEGIN_DOC + ! Number of virtual MOs + END_DOC + integer :: i + + n_virt_orb = 0 + do i = 1, mo_num + if (mo_class(i) == 'Virtual')then + n_virt_orb += 1 + endif + enddo + + call write_int(6,n_virt_orb, 'Number of virtual MOs') + +END_PROVIDER + +BEGIN_PROVIDER [ integer, n_del_orb ] + implicit none + BEGIN_DOC + ! Number of deleted MOs + END_DOC + integer :: i + + n_del_orb = 0 + do i = 1, mo_num + if (mo_class(i) == 'Deleted')then + n_del_orb += 1 + endif + enddo + + call write_int(6,n_del_orb, 'Number of deleted MOs') + +END_PROVIDER - call write_int(6,n_core_orb, 'Number of core MOs') - call write_int(6,n_inact_orb,'Number of inactive MOs') - call write_int(6,n_act_orb, 'Number of active MOs') - call write_int(6,n_virt_orb, 'Number of virtual MOs') - call write_int(6,n_del_orb, 'Number of deleted MOs') - - END_PROVIDER - - - BEGIN_PROVIDER [integer, dim_list_core_orb] -&BEGIN_PROVIDER [integer, dim_list_inact_orb] -&BEGIN_PROVIDER [integer, dim_list_virt_orb] -&BEGIN_PROVIDER [integer, dim_list_act_orb] -&BEGIN_PROVIDER [integer, dim_list_del_orb] - implicit none - BEGIN_DOC -! dimensions for the allocation of list_inact, list_virt, list_core and list_act -! it is at least 1 - END_DOC - dim_list_core_orb = max(n_core_orb,1) - dim_list_inact_orb = max(n_inact_orb,1) - dim_list_virt_orb = max(n_virt_orb,1) - dim_list_act_orb = max(n_act_orb,1) - dim_list_del_orb = max(n_del_orb,1) -END_PROVIDER - - BEGIN_PROVIDER [ integer, list_inact, (dim_list_inact_orb)] -&BEGIN_PROVIDER [ integer, list_virt, (dim_list_virt_orb)] -&BEGIN_PROVIDER [ integer, list_inact_reverse, (mo_num)] -&BEGIN_PROVIDER [ integer, list_virt_reverse, (mo_num)] -&BEGIN_PROVIDER [ integer, list_del_reverse, (mo_num)] -&BEGIN_PROVIDER [ integer, list_del, (mo_num)] -&BEGIN_PROVIDER [integer, list_core, (dim_list_core_orb)] -&BEGIN_PROVIDER [integer, list_core_reverse, (mo_num)] -&BEGIN_PROVIDER [integer, list_act, (dim_list_act_orb)] -&BEGIN_PROVIDER [integer, list_act_reverse, (mo_num)] -&BEGIN_PROVIDER [ integer(bit_kind), core_bitmask, (N_int,2)] -&BEGIN_PROVIDER [ integer(bit_kind), inact_bitmask, (N_int,2) ] -&BEGIN_PROVIDER [ integer(bit_kind), act_bitmask, (N_int,2) ] -&BEGIN_PROVIDER [ integer(bit_kind), virt_bitmask, (N_int,2) ] -&BEGIN_PROVIDER [ integer(bit_kind), del_bitmask, (N_int,2) ] - implicit none - BEGIN_DOC - ! inact_bitmask : Bitmask of the inactive orbitals which are supposed to be doubly excited - ! in post CAS methods - ! n_inact_orb : Number of inactive orbitals - ! virt_bitmask : Bitmaks of vritual orbitals which are supposed to be recieve electrons - ! in post CAS methods - ! n_virt_orb : Number of virtual orbitals - ! list_inact : List of the inactive orbitals which are supposed to be doubly excited - ! in post CAS methods - ! list_virt : List of vritual orbitals which are supposed to be recieve electrons - ! in post CAS methods - ! list_inact_reverse : reverse list of inactive orbitals - ! list_inact_reverse(i) = 0 ::> not an inactive - ! list_inact_reverse(i) = k ::> IS the kth inactive - ! list_virt_reverse : reverse list of virtual orbitals - ! list_virt_reverse(i) = 0 ::> not an virtual - ! list_virt_reverse(i) = k ::> IS the kth virtual - ! list_act(i) = index of the ith active orbital - ! - ! list_act_reverse : reverse list of active orbitals - ! list_act_reverse(i) = 0 ::> not an active - ! list_act_reverse(i) = k ::> IS the kth active orbital - END_DOC - logical :: exists - integer :: j,i - integer :: n_core_orb_tmp, n_inact_orb_tmp, n_act_orb_tmp, n_virt_orb_tmp,n_del_orb_tmp - integer :: list_core_tmp(N_int*bit_kind_size) - integer :: list_inact_tmp(N_int*bit_kind_size) - integer :: list_act_tmp(N_int*bit_kind_size) - integer :: list_virt_tmp(N_int*bit_kind_size) - integer :: list_del_tmp(N_int*bit_kind_size) - list_core = 0 - list_inact = 0 - list_act = 0 - list_virt = 0 - list_del = 0 - list_core_reverse = 0 - list_inact_reverse = 0 - list_act_reverse = 0 - list_virt_reverse = 0 - list_del_reverse = 0 - n_core_orb_tmp = 0 - n_inact_orb_tmp = 0 - n_act_orb_tmp = 0 - n_virt_orb_tmp = 0 - n_del_orb_tmp = 0 - core_bitmask = 0_bit_kind - inact_bitmask = 0_bit_kind - act_bitmask = 0_bit_kind - virt_bitmask = 0_bit_kind - do i = 1, mo_num - if(mo_class(i) == 'Core')then - n_core_orb_tmp += 1 - list_core(n_core_orb_tmp) = i - list_core_tmp(n_core_orb_tmp) = i - list_core_reverse(i) = n_core_orb_tmp - else if (mo_class(i) == 'Inactive')then - n_inact_orb_tmp += 1 - list_inact(n_inact_orb_tmp) = i - list_inact_tmp(n_inact_orb_tmp) = i - list_inact_reverse(i) = n_inact_orb_tmp - else if (mo_class(i) == 'Active')then - n_act_orb_tmp += 1 - list_act(n_act_orb_tmp) = i - list_act_tmp(n_act_orb_tmp) = i - list_act_reverse(i) = n_act_orb_tmp - else if (mo_class(i) == 'Virtual')then - n_virt_orb_tmp += 1 - list_virt(n_virt_orb_tmp) = i - list_virt_tmp(n_virt_orb_tmp) = i - list_virt_reverse(i) = n_virt_orb_tmp - else if (mo_class(i) == 'Deleted')then - n_del_orb_tmp += 1 - list_del(n_del_orb_tmp) = i - list_del_tmp(n_del_orb_tmp) = i - list_del_reverse(i) = n_del_orb_tmp - endif - enddo - - if(n_core_orb.ne.0)then - call list_to_bitstring( core_bitmask(1,1), list_core, n_core_orb, N_int) - call list_to_bitstring( core_bitmask(1,2), list_core, n_core_orb, N_int) - endif - if(n_inact_orb.ne.0)then - call list_to_bitstring( inact_bitmask(1,1), list_inact, n_inact_orb, N_int) - call list_to_bitstring( inact_bitmask(1,2), list_inact, n_inact_orb, N_int) - endif - if(n_act_orb.ne.0)then - call list_to_bitstring( act_bitmask(1,1), list_act, n_act_orb, N_int) - call list_to_bitstring( act_bitmask(1,2), list_act, n_act_orb, N_int) - endif - if(n_virt_orb.ne.0)then - call list_to_bitstring( virt_bitmask(1,1), list_virt, n_virt_orb, N_int) - call list_to_bitstring( virt_bitmask(1,2), list_virt, n_virt_orb, N_int) - endif - if(n_del_orb.ne.0)then - call list_to_bitstring( del_bitmask(1,1), list_del, n_del_orb, N_int) - call list_to_bitstring( del_bitmask(1,2), list_del, n_del_orb, N_int) - endif - - -END_PROVIDER +BEGIN_PROVIDER [ integer, n_core_inact_orb ] + implicit none + BEGIN_DOC + ! n_core + n_inact + END_DOC + integer :: i + n_core_inact_orb = 0 + do i = 1, N_int + n_core_inact_orb += popcnt(reunion_of_core_inact_bitmask(i,1)) + enddo +END_PROVIDER BEGIN_PROVIDER [integer, n_inact_act_orb ] - implicit none - n_inact_act_orb = (n_inact_orb+n_act_orb) + implicit none + BEGIN_DOC + ! n_inact + n_act + END_DOC + n_inact_act_orb = (n_inact_orb+n_act_orb) +END_PROVIDER + +BEGIN_PROVIDER [integer, dim_list_core_orb] + implicit none + BEGIN_DOC + ! dimensions for the allocation of list_core. + ! it is at least 1 + END_DOC + dim_list_core_orb = max(n_core_orb,1) +END_PROVIDER -END_PROVIDER +BEGIN_PROVIDER [integer, dim_list_inact_orb] + implicit none + BEGIN_DOC + ! dimensions for the allocation of list_inact. + ! it is at least 1 + END_DOC + dim_list_inact_orb = max(n_inact_orb,1) +END_PROVIDER -BEGIN_PROVIDER [integer, list_inact_act, (n_inact_act_orb)] - integer :: i,itmp - itmp = 0 - do i = 1, n_inact_orb - itmp += 1 - list_inact_act(itmp) = list_inact(i) - enddo - do i = 1, n_act_orb - itmp += 1 - list_inact_act(itmp) = list_act(i) - enddo -END_PROVIDER +BEGIN_PROVIDER [integer, dim_list_act_orb] + implicit none + BEGIN_DOC + ! dimensions for the allocation of list_act. + ! it is at least 1 + END_DOC + dim_list_act_orb = max(n_act_orb,1) +END_PROVIDER + +BEGIN_PROVIDER [integer, dim_list_virt_orb] + implicit none + BEGIN_DOC + ! dimensions for the allocation of list_virt. + ! it is at least 1 + END_DOC + dim_list_virt_orb = max(n_virt_orb,1) +END_PROVIDER + +BEGIN_PROVIDER [integer, dim_list_del_orb] + implicit none + BEGIN_DOC + ! dimensions for the allocation of list_del. + ! it is at least 1 + END_DOC + dim_list_del_orb = max(n_del_orb,1) +END_PROVIDER BEGIN_PROVIDER [integer, n_core_inact_act_orb ] - implicit none - n_core_inact_act_orb = (n_core_orb + n_inact_orb + n_act_orb) + implicit none + BEGIN_DOC + ! Number of core inactive and active MOs + END_DOC + n_core_inact_act_orb = (n_core_orb + n_inact_orb + n_act_orb) +END_PROVIDER + -END_PROVIDER - BEGIN_PROVIDER [integer, list_core_inact_act, (n_core_inact_act_orb)] -&BEGIN_PROVIDER [ integer, list_core_inact_act_reverse, (n_core_inact_act_orb)] - integer :: i,itmp - itmp = 0 - do i = 1, n_core_orb - itmp += 1 - list_core_inact_act(itmp) = list_core(i) - enddo - do i = 1, n_inact_orb - itmp += 1 - list_core_inact_act(itmp) = list_inact(i) - enddo - do i = 1, n_act_orb - itmp += 1 - list_core_inact_act(itmp) = list_act(i) - enddo + + BEGIN_PROVIDER [ integer(bit_kind), core_bitmask , (N_int,2) ] +&BEGIN_PROVIDER [ integer(bit_kind), inact_bitmask, (N_int,2) ] +&BEGIN_PROVIDER [ integer(bit_kind), act_bitmask , (N_int,2) ] +&BEGIN_PROVIDER [ integer(bit_kind), virt_bitmask , (N_int,2) ] +&BEGIN_PROVIDER [ integer(bit_kind), del_bitmask , (N_int,2) ] + implicit none + BEGIN_DOC + ! Bitmask identifying the core/inactive/active/virtual/deleted MOs + END_DOC - integer :: occ_inact(N_int*bit_kind_size) - occ_inact = 0 - call bitstring_to_list(reunion_of_core_inact_act_bitmask(1,1), occ_inact(1), itest, N_int) - list_inact_reverse = 0 - do i = 1, n_core_inact_act_orb - list_core_inact_act_reverse(occ_inact(i)) = i - enddo -END_PROVIDER + core_bitmask = 0_bit_kind + inact_bitmask = 0_bit_kind + act_bitmask = 0_bit_kind + virt_bitmask = 0_bit_kind + del_bitmask = 0_bit_kind + + if(n_core_orb > 0)then + call list_to_bitstring( core_bitmask(1,1), list_core, n_core_orb, N_int) + call list_to_bitstring( core_bitmask(1,2), list_core, n_core_orb, N_int) + endif + if(n_inact_orb > 0)then + call list_to_bitstring( inact_bitmask(1,1), list_inact, n_inact_orb, N_int) + call list_to_bitstring( inact_bitmask(1,2), list_inact, n_inact_orb, N_int) + endif + if(n_act_orb > 0)then + call list_to_bitstring( act_bitmask(1,1), list_act, n_act_orb, N_int) + call list_to_bitstring( act_bitmask(1,2), list_act, n_act_orb, N_int) + endif + if(n_virt_orb > 0)then + call list_to_bitstring( virt_bitmask(1,1), list_virt, n_virt_orb, N_int) + call list_to_bitstring( virt_bitmask(1,2), list_virt, n_virt_orb, N_int) + endif + if(n_del_orb > 0)then + call list_to_bitstring( del_bitmask(1,1), list_del, n_del_orb, N_int) + call list_to_bitstring( del_bitmask(1,2), list_del, n_del_orb, N_int) + endif + +END_PROVIDER + + + + + + BEGIN_PROVIDER [ integer, list_core , (dim_list_core_orb) ] +&BEGIN_PROVIDER [ integer, list_core_reverse, (mo_num) ] + implicit none + BEGIN_DOC + ! List of MO indices which are in the core. + END_DOC + integer :: i, n + list_core = 0 + list_core_reverse = 0 + + n=0 + do i = 1, mo_num + if(mo_class(i) == 'Core')then + n += 1 + list_core(n) = i + list_core_reverse(i) = n + endif + enddo + +END_PROVIDER + + BEGIN_PROVIDER [ integer, list_inact , (dim_list_inact_orb) ] +&BEGIN_PROVIDER [ integer, list_inact_reverse, (mo_num) ] + implicit none + BEGIN_DOC + ! List of MO indices which are inactive. + END_DOC + integer :: i, n + list_inact = 0 + list_inact_reverse = 0 + + n=0 + do i = 1, mo_num + if (mo_class(i) == 'Inactive')then + n += 1 + list_inact(n) = i + list_inact_reverse(i) = n + endif + enddo + +END_PROVIDER + + BEGIN_PROVIDER [ integer, list_virt , (dim_list_virt_orb) ] +&BEGIN_PROVIDER [ integer, list_virt_reverse, (mo_num) ] + implicit none + BEGIN_DOC + ! List of MO indices which are virtual + END_DOC + integer :: i, n + list_virt = 0 + list_virt_reverse = 0 + + n=0 + do i = 1, mo_num + if (mo_class(i) == 'Virtual')then + n += 1 + list_virt(n) = i + list_virt_reverse(i) = n + endif + enddo + +END_PROVIDER + + BEGIN_PROVIDER [ integer, list_del , (dim_list_del_orb) ] +&BEGIN_PROVIDER [ integer, list_del_reverse, (mo_num) ] + implicit none + BEGIN_DOC + ! List of MO indices which are deleted. + END_DOC + integer :: i, n + list_del = 0 + list_del_reverse = 0 + + n=0 + do i = 1, mo_num + if (mo_class(i) == 'Deleted')then + n += 1 + list_del(n) = i + list_del_reverse(i) = n + endif + enddo + +END_PROVIDER + + BEGIN_PROVIDER [ integer, list_act , (dim_list_act_orb) ] +&BEGIN_PROVIDER [ integer, list_act_reverse, (mo_num) ] + implicit none + BEGIN_DOC + ! List of MO indices which are in the active. + END_DOC + integer :: i, n + list_act = 0 + list_act_reverse = 0 + + n=0 + do i = 1, mo_num + if (mo_class(i) == 'Active')then + n += 1 + list_act(n) = i + list_act_reverse(i) = n + endif + enddo + +END_PROVIDER + + + + BEGIN_PROVIDER [ integer, list_core_inact , (n_core_inact_orb) ] +&BEGIN_PROVIDER [ integer, list_core_inact_reverse, (mo_num) ] + implicit none + BEGIN_DOC + ! List of indices of the core and inactive MOs + END_DOC + integer :: i,itmp + call bitstring_to_list(reunion_of_core_inact_bitmask(1,1), list_core_inact, itmp, N_int) + list_core_inact_reverse = 0 + ASSERT (itmp == n_core_inact_orb) + do i = 1, n_core_inact_orb + list_core_inact_reverse(list_core_inact(i)) = i + enddo +END_PROVIDER + + + BEGIN_PROVIDER [ integer, list_core_inact_act , (n_core_inact_act_orb) ] +&BEGIN_PROVIDER [ integer, list_core_inact_act_reverse, (mo_num) ] + implicit none + BEGIN_DOC + ! List of indices of the core inactive and active MOs + END_DOC + integer :: i,itmp + call bitstring_to_list(reunion_of_core_inact_act_bitmask(1,1), list_core_inact_act, itmp, N_int) + list_core_inact_act_reverse = 0 + ASSERT (itmp == n_core_inact_act_orb) + do i = 1, n_core_inact_act_orb + list_core_inact_act_reverse(list_core_inact_act(i)) = i + enddo +END_PROVIDER + + + BEGIN_PROVIDER [ integer, list_inact_act , (n_inact_act_orb) ] +&BEGIN_PROVIDER [ integer, list_inact_act_reverse, (mo_num) ] + implicit none + BEGIN_DOC + ! List of indices of the inactive and active MOs + END_DOC + integer :: i,itmp + call bitstring_to_list(reunion_of_inact_act_bitmask(1,1), list_inact_act, itmp, N_int) + list_inact_act_reverse = 0 + ASSERT (itmp == n_inact_act_orb) + do i = 1, n_inact_act_orb + list_inact_act_reverse(list_inact_act(i)) = i + enddo +END_PROVIDER + diff --git a/src/casscf/bielec.irp.f b/src/casscf/bielec.irp.f index 8e08243d..e1ff305c 100644 --- a/src/casscf/bielec.irp.f +++ b/src/casscf/bielec.irp.f @@ -1,4 +1,4 @@ - BEGIN_PROVIDER [real*8, bielec_PQxx, (mo_num, mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb)] +BEGIN_PROVIDER [real*8, bielec_PQxx, (mo_num, mo_num,n_core_inact_orb+n_act_orb,n_core_inact_orb+n_act_orb)] BEGIN_DOC ! bielec_PQxx : integral (pq|xx) with p,q arbitrary, x core or active ! indices are unshifted orbital numbers @@ -9,16 +9,16 @@ bielec_PQxx = 0.d0 - do i=1,n_core_orb + do i=1,n_core_inact_orb ii=list_core(i) - do j=i,n_core_orb + do j=i,n_core_inact_orb jj=list_core(j) call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,bielec_PQxx(1,1,i,j),mo_integrals_map) bielec_PQxx(:,:,j,i)=bielec_PQxx(:,:,i,j) end do do j=1,n_act_orb jj=list_act(j) - j3=j+n_core_orb + j3=j+n_core_inact_orb call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,bielec_PQxx(1,1,i,j3),mo_integrals_map) bielec_PQxx(:,:,j3,i)=bielec_PQxx(:,:,i,j3) end do @@ -28,10 +28,10 @@ ! (ij|pq) do i=1,n_act_orb ii=list_act(i) - i3=i+n_core_orb + i3=i+n_core_inact_orb do j=i,n_act_orb jj=list_act(j) - j3=j+n_core_orb + j3=j+n_core_inact_orb call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,bielec_PQxx(1,1,i3,j3),mo_integrals_map) bielec_PQxx(:,:,j3,i3)=bielec_PQxx(:,:,i3,j3) end do @@ -41,7 +41,7 @@ END_PROVIDER -BEGIN_PROVIDER [real*8, bielec_PxxQ, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb, mo_num)] +BEGIN_PROVIDER [real*8, bielec_PxxQ, (mo_num,n_core_inact_orb+n_act_orb,n_core_inact_orb+n_act_orb, mo_num)] BEGIN_DOC ! bielec_PxxQ : integral (px|xq) with p,q arbitrary, x core or active ! indices are unshifted orbital numbers @@ -55,9 +55,9 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_a bielec_PxxQ = 0.d0 - do i=1,n_core_orb + do i=1,n_core_inact_orb ii=list_core(i) - do j=i,n_core_orb + do j=i,n_core_inact_orb jj=list_core(j) call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array,mo_integrals_map) do p=1,mo_num @@ -69,7 +69,7 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_a end do do j=1,n_act_orb jj=list_act(j) - j3=j+n_core_orb + j3=j+n_core_inact_orb call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array,mo_integrals_map) do p=1,mo_num do q=1,mo_num @@ -84,10 +84,10 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_a ! (ip|qj) do i=1,n_act_orb ii=list_act(i) - i3=i+n_core_orb + i3=i+n_core_inact_orb do j=i,n_act_orb jj=list_act(j) - j3=j+n_core_orb + j3=j+n_core_inact_orb call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array,mo_integrals_map) do p=1,mo_num do q=1,mo_num From 1db247b27e872ad226b59cded5df1b10ca7ef823 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 2 Jul 2019 22:52:47 +0200 Subject: [PATCH 32/59] n_core -> n_core_inactive --- src/casscf/bielec_natorb.irp.f | 44 ++++++++++++------------ src/casscf/gradient.irp.f | 26 +++++++------- src/casscf/hessian.irp.f | 62 +++++++++++++++++----------------- src/casscf/mcscf_fock.irp.f | 4 +-- src/casscf/natorb.irp.f | 4 +-- src/casscf/neworbs.irp.f | 8 ++--- src/casscf/tot_en.irp.f | 36 ++++++++++---------- 7 files changed, 92 insertions(+), 92 deletions(-) diff --git a/src/casscf/bielec_natorb.irp.f b/src/casscf/bielec_natorb.irp.f index ca1c8e9d..53d74e14 100644 --- a/src/casscf/bielec_natorb.irp.f +++ b/src/casscf/bielec_natorb.irp.f @@ -1,4 +1,4 @@ - BEGIN_PROVIDER [real*8, bielec_PQxx_no, (mo_num, mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb)] + BEGIN_PROVIDER [real*8, bielec_PQxx_no, (mo_num, mo_num,n_core_inact_orb+n_act_orb,n_core_inact_orb+n_act_orb)] BEGIN_DOC ! integral (pq|xx) in the basis of natural MOs ! indices are unshifted orbital numbers @@ -10,8 +10,8 @@ bielec_PQxx_no(:,:,:,:) = bielec_PQxx(:,:,:,:) do j=1,mo_num - do k=1,n_core_orb+n_act_orb - do l=1,n_core_orb+n_act_orb + do k=1,n_core_inact_orb+n_act_orb + do l=1,n_core_inact_orb+n_act_orb do p=1,n_act_orb d(p)=0.D0 end do @@ -29,8 +29,8 @@ end do ! 2nd quarter do j=1,mo_num - do k=1,n_core_orb+n_act_orb - do l=1,n_core_orb+n_act_orb + do k=1,n_core_inact_orb+n_act_orb + do l=1,n_core_inact_orb+n_act_orb do p=1,n_act_orb d(p)=0.D0 end do @@ -49,18 +49,18 @@ ! 3rd quarter do j=1,mo_num do k=1,mo_num - do l=1,n_core_orb+n_act_orb + do l=1,n_core_inact_orb+n_act_orb do p=1,n_act_orb d(p)=0.D0 end do do p=1,n_act_orb pp=n_act_orb-p+1 do q=1,n_act_orb - d(pp)+=bielec_PQxx_no(j,k,n_core_orb+q,l)*natorbsCI(q,p) + d(pp)+=bielec_PQxx_no(j,k,n_core_inact_orb+q,l)*natorbsCI(q,p) end do end do do p=1,n_act_orb - bielec_PQxx_no(j,k,n_core_orb+p,l)=d(p) + bielec_PQxx_no(j,k,n_core_inact_orb+p,l)=d(p) end do end do end do @@ -68,18 +68,18 @@ ! 4th quarter do j=1,mo_num do k=1,mo_num - do l=1,n_core_orb+n_act_orb + do l=1,n_core_inact_orb+n_act_orb do p=1,n_act_orb d(p)=0.D0 end do do p=1,n_act_orb pp=n_act_orb-p+1 do q=1,n_act_orb - d(pp)+=bielec_PQxx_no(j,k,l,n_core_orb+q)*natorbsCI(q,p) + d(pp)+=bielec_PQxx_no(j,k,l,n_core_inact_orb+q)*natorbsCI(q,p) end do end do do p=1,n_act_orb - bielec_PQxx_no(j,k,l,n_core_orb+p)=d(p) + bielec_PQxx_no(j,k,l,n_core_inact_orb+p)=d(p) end do end do end do @@ -89,7 +89,7 @@ END_PROVIDER -BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_orb+n_act_orb,n_core_orb+n_act_orb, mo_num)] +BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_inact_orb+n_act_orb,n_core_inact_orb+n_act_orb, mo_num)] BEGIN_DOC ! integral (px|xq) in the basis of natural MOs ! indices are unshifted orbital numbers @@ -101,8 +101,8 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_orb+n_act_orb,n_core_orb+ bielec_PxxQ_no(:,:,:,:) = bielec_PxxQ(:,:,:,:) do j=1,mo_num - do k=1,n_core_orb+n_act_orb - do l=1,n_core_orb+n_act_orb + do k=1,n_core_inact_orb+n_act_orb + do l=1,n_core_inact_orb+n_act_orb do p=1,n_act_orb d(p)=0.D0 end do @@ -120,8 +120,8 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_orb+n_act_orb,n_core_orb+ end do ! 2nd quarter do j=1,mo_num - do k=1,n_core_orb+n_act_orb - do l=1,n_core_orb+n_act_orb + do k=1,n_core_inact_orb+n_act_orb + do l=1,n_core_inact_orb+n_act_orb do p=1,n_act_orb d(p)=0.D0 end do @@ -140,18 +140,18 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_orb+n_act_orb,n_core_orb+ ! 3rd quarter do j=1,mo_num do k=1,mo_num - do l=1,n_core_orb+n_act_orb + do l=1,n_core_inact_orb+n_act_orb do p=1,n_act_orb d(p)=0.D0 end do do p=1,n_act_orb pp=n_act_orb-p+1 do q=1,n_act_orb - d(pp)+=bielec_PxxQ_no(j,n_core_orb+q,l,k)*natorbsCI(q,p) + d(pp)+=bielec_PxxQ_no(j,n_core_inact_orb+q,l,k)*natorbsCI(q,p) end do end do do p=1,n_act_orb - bielec_PxxQ_no(j,n_core_orb+p,l,k)=d(p) + bielec_PxxQ_no(j,n_core_inact_orb+p,l,k)=d(p) end do end do end do @@ -159,18 +159,18 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_orb+n_act_orb,n_core_orb+ ! 4th quarter do j=1,mo_num do k=1,mo_num - do l=1,n_core_orb+n_act_orb + do l=1,n_core_inact_orb+n_act_orb do p=1,n_act_orb d(p)=0.D0 end do do p=1,n_act_orb pp=n_act_orb-p+1 do q=1,n_act_orb - d(pp)+=bielec_PxxQ_no(j,l,n_core_orb+q,k)*natorbsCI(q,p) + d(pp)+=bielec_PxxQ_no(j,l,n_core_inact_orb+q,k)*natorbsCI(q,p) end do end do do p=1,n_act_orb - bielec_PxxQ_no(j,l,n_core_orb+p,k)=d(p) + bielec_PxxQ_no(j,l,n_core_inact_orb+p,k)=d(p) end do end do end do diff --git a/src/casscf/gradient.irp.f b/src/casscf/gradient.irp.f index 883a4665..00340a92 100644 --- a/src/casscf/gradient.irp.f +++ b/src/casscf/gradient.irp.f @@ -5,7 +5,7 @@ BEGIN_PROVIDER [ integer, nMonoEx ] ! Number of single excitations END_DOC implicit none - nMonoEx=n_core_orb*n_act_orb+n_core_orb*n_virt_orb+n_act_orb*n_virt_orb + nMonoEx=n_core_inact_orb*n_act_orb+n_core_inact_orb*n_virt_orb+n_act_orb*n_virt_orb END_PROVIDER BEGIN_PROVIDER [integer, excit, (2,nMonoEx)] @@ -17,8 +17,8 @@ END_PROVIDER implicit none integer :: i,t,a,ii,tt,aa,indx indx=0 - do ii=1,n_core_orb - i=list_core(ii) + do ii=1,n_core_inact_orb + i=list_core_inact(ii) do tt=1,n_act_orb t=list_act(tt) indx+=1 @@ -28,8 +28,8 @@ END_PROVIDER end do end do - do ii=1,n_core_orb - i=list_core(ii) + do ii=1,n_core_inact_orb + i=list_core_inact(ii) do aa=1,n_virt_orb a=list_virt(aa) indx+=1 @@ -145,14 +145,14 @@ BEGIN_PROVIDER [real*8, gradvec2, (nMonoEx)] real*8 :: norm_grad indx=0 - do i=1,n_core_orb + do i=1,n_core_inact_orb do t=1,n_act_orb indx+=1 gradvec2(indx)=gradvec_it(i,t) end do end do - do i=1,n_core_orb + do i=1,n_core_inact_orb do a=1,n_virt_orb indx+=1 gradvec2(indx)=gradvec_ia(i,a) @@ -181,7 +181,7 @@ END_PROVIDER real*8 function gradvec_it(i,t) BEGIN_DOC - ! the orbital gradient core -> active + ! the orbital gradient core/inactive -> active ! we assume natural orbitals END_DOC implicit none @@ -190,16 +190,16 @@ real*8 function gradvec_it(i,t) integer :: ii,tt,v,vv,x,y integer :: x3,y3 - ii=list_core(i) + ii=list_core_inact(i) tt=list_act(t) gradvec_it=2.D0*(Fipq(tt,ii)+Fapq(tt,ii)) gradvec_it-=occnum(tt)*Fipq(ii,tt) do v=1,n_act_orb vv=list_act(v) do x=1,n_act_orb - x3=x+n_core_orb + x3=x+n_core_inact_orb do y=1,n_act_orb - y3=y+n_core_orb + y3=y+n_core_inact_orb gradvec_it-=2.D0*P0tuvx_no(t,v,x,y)*bielec_PQxx_no(ii,vv,x3,y3) end do end do @@ -209,12 +209,12 @@ end function gradvec_it real*8 function gradvec_ia(i,a) BEGIN_DOC - ! the orbital gradient core -> virtual + ! the orbital gradient core/inactive -> virtual END_DOC implicit none integer :: i,a,ii,aa - ii=list_core(i) + ii=list_core_inact(i) aa=list_virt(a) gradvec_ia=2.D0*(Fipq(aa,ii)+Fapq(aa,ii)) gradvec_ia*=2.D0 diff --git a/src/casscf/hessian.irp.f b/src/casscf/hessian.irp.f index e047c5fd..75a27410 100644 --- a/src/casscf/hessian.irp.f +++ b/src/casscf/hessian.irp.f @@ -204,10 +204,10 @@ BEGIN_PROVIDER [real*8, hessmat2, (nMonoEx,nMonoEx)] endif indx=1 - do i=1,n_core_orb + do i=1,n_core_inact_orb do t=1,n_act_orb jndx=indx - do j=i,n_core_orb + do j=i,n_core_inact_orb if (i.eq.j) then ustart=t else @@ -219,7 +219,7 @@ BEGIN_PROVIDER [real*8, hessmat2, (nMonoEx,nMonoEx)] jndx+=1 end do end do - do j=1,n_core_orb + do j=1,n_core_inact_orb do a=1,n_virt_orb hessmat2(indx,jndx)=hessmat_itja(i,t,j,a) hessmat2(jndx,indx)=hessmat2(indx,jndx) @@ -237,10 +237,10 @@ BEGIN_PROVIDER [real*8, hessmat2, (nMonoEx,nMonoEx)] end do end do - do i=1,n_core_orb + do i=1,n_core_inact_orb do a=1,n_virt_orb jndx=indx - do j=i,n_core_orb + do j=i,n_core_inact_orb if (i.eq.j) then bstart=a else @@ -286,7 +286,7 @@ END_PROVIDER real*8 function hessmat_itju(i,t,j,u) BEGIN_DOC - ! the orbital hessian for core->act,core->act + ! the orbital hessian for core/inactive -> active, core/inactive -> active ! i, t, j, u are list indices, the corresponding orbitals are ii,tt,jj,uu ! ! we assume natural orbitals @@ -295,7 +295,7 @@ real*8 function hessmat_itju(i,t,j,u) integer :: i,t,j,u,ii,tt,uu,v,vv,x,xx,y,jj real*8 :: term,t2 - ii=list_core(i) + ii=list_core_inact(i) tt=list_act(t) if (i.eq.j) then if (t.eq.u) then @@ -343,7 +343,7 @@ real*8 function hessmat_itju(i,t,j,u) end if else ! it/ju - jj=list_core(j) + jj=list_core_inact(j) uu=list_act(u) if (t.eq.u) then term=occnum(tt)*Fipq(ii,jj) @@ -374,16 +374,16 @@ end function hessmat_itju real*8 function hessmat_itja(i,t,j,a) BEGIN_DOC - ! the orbital hessian for core->act,core->virt + ! the orbital hessian for core/inactive -> active, core/inactive -> virtual END_DOC implicit none integer :: i,t,j,a,ii,tt,jj,aa,v,vv,x,y real*8 :: term ! it/ja - ii=list_core(i) + ii=list_core_inact(i) tt=list_act(t) - jj=list_core(j) + jj=list_core_inact(j) aa=list_virt(a) term=2.D0*(4.D0*bielec_pxxq_no(aa,j,i,tt) & -bielec_pqxx_no(aa,tt,i,j) -bielec_pxxq_no(aa,i,j,tt)) @@ -407,17 +407,17 @@ end function hessmat_itja real*8 function hessmat_itua(i,t,u,a) BEGIN_DOC - ! the orbital hessian for core->act,act->virt + ! the orbital hessian for core/inactive -> active, active -> virtual END_DOC implicit none integer :: i,t,u,a,ii,tt,uu,aa,v,vv,x,xx,u3,t3,v3 real*8 :: term - ii=list_core(i) + ii=list_core_inact(i) tt=list_act(t) - t3=t+n_core_orb + t3=t+n_core_inact_orb uu=list_act(u) - u3=u+n_core_orb + u3=u+n_core_inact_orb aa=list_virt(a) if (t.eq.u) then term=-occnum(tt)*Fipq(aa,ii) @@ -428,11 +428,11 @@ real*8 function hessmat_itua(i,t,u,a) +bielec_pxxq_no(aa,t3,u3,ii)) do v=1,n_act_orb vv=list_act(v) - v3=v+n_core_orb + v3=v+n_core_inact_orb do x=1,n_act_orb integer :: x3 xx=list_act(x) - x3=x+n_core_orb + x3=x+n_core_inact_orb term-=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx_no(aa,ii,v3,x3) & +(P0tuvx_no(t,v,u,x)+P0tuvx_no(t,v,x,u)) & *bielec_pqxx_no(aa,xx,v3,i)) @@ -448,13 +448,13 @@ end function hessmat_itua real*8 function hessmat_iajb(i,a,j,b) BEGIN_DOC - ! the orbital hessian for core->virt,core->virt + ! the orbital hessian for core/inactive -> virtual, core/inactive -> virtual END_DOC implicit none integer :: i,a,j,b,ii,aa,jj,bb real*8 :: term - ii=list_core(i) + ii=list_core_inact(i) aa=list_virt(a) if (i.eq.j) then if (a.eq.b) then @@ -469,7 +469,7 @@ real*8 function hessmat_iajb(i,a,j,b) end if else ! ia/jb - jj=list_core(j) + jj=list_core_inact(j) bb=list_virt(b) term=2.D0*(4.D0*bielec_pxxq_no(aa,i,j,bb)-bielec_pqxx_no(aa,bb,i,j) & -bielec_pxxq_no(aa,j,i,bb)) @@ -484,17 +484,17 @@ end function hessmat_iajb real*8 function hessmat_iatb(i,a,t,b) BEGIN_DOC - ! the orbital hessian for core->virt,act->virt + ! the orbital hessian for core/inactive -> virtual, active -> virtual END_DOC implicit none integer :: i,a,t,b,ii,aa,tt,bb,v,vv,x,y,v3,t3 real*8 :: term - ii=list_core(i) + ii=list_core_inact(i) aa=list_virt(a) tt=list_act(t) bb=list_virt(b) - t3=t+n_core_orb + t3=t+n_core_inact_orb term=occnum(tt)*(4.D0*bielec_pxxq_no(aa,i,t3,bb)-bielec_pxxq_no(aa,t3,i,bb)& -bielec_pqxx_no(aa,bb,i,t3)) if (a.eq.b) then @@ -533,10 +533,10 @@ real*8 function hessmat_taub(t,a,u,b) t1-=occnum(tt)*Fipq(tt,tt) do v=1,n_act_orb vv=list_act(v) - v3=v+n_core_orb + v3=v+n_core_inact_orb do x=1,n_act_orb xx=list_act(x) - x3=x+n_core_orb + x3=x+n_core_inact_orb t2+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx_no(aa,aa,v3,x3) & +(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* & bielec_pxxq_no(aa,x3,v3,aa)) @@ -552,10 +552,10 @@ real*8 function hessmat_taub(t,a,u,b) term=occnum(tt)*Fipq(aa,bb) do v=1,n_act_orb vv=list_act(v) - v3=v+n_core_orb + v3=v+n_core_inact_orb do x=1,n_act_orb xx=list_act(x) - x3=x+n_core_orb + x3=x+n_core_inact_orb term+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx_no(aa,bb,v3,x3) & +(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v)) & *bielec_pxxq_no(aa,x3,v3,bb)) @@ -569,10 +569,10 @@ real*8 function hessmat_taub(t,a,u,b) term=0.D0 do v=1,n_act_orb vv=list_act(v) - v3=v+n_core_orb + v3=v+n_core_inact_orb do x=1,n_act_orb xx=list_act(x) - x3=x+n_core_orb + x3=x+n_core_inact_orb term+=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx_no(aa,bb,v3,x3) & +(P0tuvx_no(t,x,v,u)+P0tuvx_no(t,x,u,v)) & *bielec_pxxq_no(aa,x3,v3,bb)) @@ -606,14 +606,14 @@ BEGIN_PROVIDER [real*8, hessdiag, (nMonoEx)] real*8 :: hessmat_itju,hessmat_iajb,hessmat_taub indx=0 - do i=1,n_core_orb + do i=1,n_core_inact_orb do t=1,n_act_orb indx+=1 hessdiag(indx)=hessmat_itju(i,t,i,t) end do end do - do i=1,n_core_orb + do i=1,n_core_inact_orb do a=1,n_virt_orb indx+=1 hessdiag(indx)=hessmat_iajb(i,a,i,a) diff --git a/src/casscf/mcscf_fock.irp.f b/src/casscf/mcscf_fock.irp.f index 84b87248..e4568405 100644 --- a/src/casscf/mcscf_fock.irp.f +++ b/src/casscf/mcscf_fock.irp.f @@ -12,8 +12,8 @@ BEGIN_PROVIDER [real*8, Fipq, (mo_num,mo_num) ] end do ! the inactive Fock matrix - do k=1,n_core_orb - kk=list_core(k) + do k=1,n_core_inact_orb + kk=list_core_inact(k) do q=1,mo_num do p=1,mo_num Fipq(p,q)+=2.D0*bielec_pqxx_no(p,q,k,k) -bielec_pxxq_no(p,k,k,q) diff --git a/src/casscf/natorb.irp.f b/src/casscf/natorb.irp.f index 52cd3747..dcbcd413 100644 --- a/src/casscf/natorb.irp.f +++ b/src/casscf/natorb.irp.f @@ -6,8 +6,8 @@ integer :: i occnum=0.D0 - do i=1,n_core_orb - occnum(list_core(i))=2.D0 + do i=1,n_core_inact_orb + occnum(list_core_inact(i))=2.D0 end do do i=1,n_act_orb diff --git a/src/casscf/neworbs.irp.f b/src/casscf/neworbs.irp.f index f4319485..5cb423d6 100644 --- a/src/casscf/neworbs.irp.f +++ b/src/casscf/neworbs.irp.f @@ -122,8 +122,8 @@ BEGIN_PROVIDER [real*8, Umat, (mo_num,mo_num) ] ! the orbital rotation matrix T Tmat(:,:)=0.D0 indx=1 - do i=1,n_core_orb - ii=list_core(i) + do i=1,n_core_inact_orb + ii=list_core_inact(i) do t=1,n_act_orb tt=list_act(t) indx+=1 @@ -131,8 +131,8 @@ BEGIN_PROVIDER [real*8, Umat, (mo_num,mo_num) ] Tmat(tt,ii)=-SXvector(indx) end do end do - do i=1,n_core_orb - ii=list_core(i) + do i=1,n_core_inact_orb + ii=list_core_inact(i) do a=1,n_virt_orb aa=list_virt(a) indx+=1 diff --git a/src/casscf/tot_en.irp.f b/src/casscf/tot_en.irp.f index ce787232..1d70e087 100644 --- a/src/casscf/tot_en.irp.f +++ b/src/casscf/tot_en.irp.f @@ -10,19 +10,19 @@ real*8 :: e_one_all,e_two_all e_one_all=0.D0 e_two_all=0.D0 - do i=1,n_core_orb - ii=list_core(i) + do i=1,n_core_inact_orb + ii=list_core_inact(i) e_one_all+=2.D0*mo_one_e_integrals(ii,ii) - do j=1,n_core_orb - jj=list_core(j) + do j=1,n_core_inact_orb + jj=list_core_inact(j) e_two_all+=2.D0*bielec_PQxx(ii,ii,j,j)-bielec_PQxx(ii,jj,j,i) end do do t=1,n_act_orb tt=list_act(t) - t3=t+n_core_orb + t3=t+n_core_inact_orb do u=1,n_act_orb uu=list_act(u) - u3=u+n_core_orb + u3=u+n_core_inact_orb e_two_all+=D0tu(t,u)*(2.D0*bielec_PQxx(tt,uu,i,i) & -bielec_PQxx(tt,ii,i,u3)) end do @@ -34,9 +34,9 @@ uu=list_act(u) e_one_all+=D0tu(t,u)*mo_one_e_integrals(tt,uu) do v=1,n_act_orb - v3=v+n_core_orb + v3=v+n_core_inact_orb do x=1,n_act_orb - x3=x+n_core_orb + x3=x+n_core_inact_orb e_two_all +=P0tuvx(t,u,v,x)*bielec_PQxx(tt,uu,v3,x3) end do end do @@ -44,12 +44,12 @@ end do ecore =nuclear_repulsion ecore_bis=nuclear_repulsion - do i=1,n_core_orb - ii=list_core(i) + do i=1,n_core_inact_orb + ii=list_core_inact(i) ecore +=2.D0*mo_one_e_integrals(ii,ii) ecore_bis+=2.D0*mo_one_e_integrals(ii,ii) - do j=1,n_core_orb - jj=list_core(j) + do j=1,n_core_inact_orb + jj=list_core_inact(j) ecore +=2.D0*bielec_PQxx(ii,ii,j,j)-bielec_PQxx(ii,jj,j,i) ecore_bis+=2.D0*bielec_PxxQ(ii,i,j,jj)-bielec_PxxQ(ii,j,j,ii) end do @@ -61,14 +61,14 @@ etwo_ter=0.D0 do t=1,n_act_orb tt=list_act(t) - t3=t+n_core_orb + t3=t+n_core_inact_orb do u=1,n_act_orb uu=list_act(u) - u3=u+n_core_orb + u3=u+n_core_inact_orb eone +=D0tu(t,u)*mo_one_e_integrals(tt,uu) eone_bis+=D0tu(t,u)*mo_one_e_integrals(tt,uu) - do i=1,n_core_orb - ii=list_core(i) + do i=1,n_core_inact_orb + ii=list_core_inact(i) eone +=D0tu(t,u)*(2.D0*bielec_PQxx(tt,uu,i,i) & -bielec_PQxx(tt,ii,i,u3)) eone_bis+=D0tu(t,u)*(2.D0*bielec_PxxQ(tt,u3,i,ii) & @@ -76,10 +76,10 @@ end do do v=1,n_act_orb vv=list_act(v) - v3=v+n_core_orb + v3=v+n_core_inact_orb do x=1,n_act_orb xx=list_act(x) - x3=x+n_core_orb + x3=x+n_core_inact_orb real*8 :: h1,h2,h3 h1=bielec_PQxx(tt,uu,v3,x3) h2=bielec_PxxQ(tt,u3,v3,xx) From 05df77ddb82606102278f052b5e7b98b287e8ad6 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Tue, 2 Jul 2019 23:30:36 +0200 Subject: [PATCH 33/59] Fixed previous commit --- src/bitmask/core_inact_act_virt.irp.f | 16 ++++++++++++ src/casscf/bielec.irp.f | 8 +++--- src/selectors_full/selectors.irp.f | 35 +++++++-------------------- 3 files changed, 29 insertions(+), 30 deletions(-) diff --git a/src/bitmask/core_inact_act_virt.irp.f b/src/bitmask/core_inact_act_virt.irp.f index ae17fc67..ff7ee2de 100644 --- a/src/bitmask/core_inact_act_virt.irp.f +++ b/src/bitmask/core_inact_act_virt.irp.f @@ -228,6 +228,8 @@ END_PROVIDER list_core_reverse(i) = n endif enddo + print *, 'Core MOs:' + print *, list_core(1:n_core_orb) END_PROVIDER @@ -249,6 +251,8 @@ END_PROVIDER list_inact_reverse(i) = n endif enddo + print *, 'Inactive MOs:' + print *, list_inact(1:n_inact_orb) END_PROVIDER @@ -270,6 +274,8 @@ END_PROVIDER list_virt_reverse(i) = n endif enddo + print *, 'Virtual MOs:' + print *, list_virt(1:n_virt_orb) END_PROVIDER @@ -291,6 +297,8 @@ END_PROVIDER list_del_reverse(i) = n endif enddo + print *, 'Deleted MOs:' + print *, list_del(1:n_del_orb) END_PROVIDER @@ -312,6 +320,8 @@ END_PROVIDER list_act_reverse(i) = n endif enddo + print *, 'Active MOs:' + print *, list_act(1:n_act_orb) END_PROVIDER @@ -330,6 +340,8 @@ END_PROVIDER do i = 1, n_core_inact_orb list_core_inact_reverse(list_core_inact(i)) = i enddo + print *, 'Core and Inactive MOs:' + print *, list_core_inact(1:n_core_inact_orb) END_PROVIDER @@ -346,6 +358,8 @@ END_PROVIDER do i = 1, n_core_inact_act_orb list_core_inact_act_reverse(list_core_inact_act(i)) = i enddo + print *, 'Core, Inactive and Active MOs:' + print *, list_core_inact_act(1:n_core_inact_act_orb) END_PROVIDER @@ -362,5 +376,7 @@ END_PROVIDER do i = 1, n_inact_act_orb list_inact_act_reverse(list_inact_act(i)) = i enddo + print *, 'Inactive and Active MOs:' + print *, list_inact_act(1:n_inact_act_orb) END_PROVIDER diff --git a/src/casscf/bielec.irp.f b/src/casscf/bielec.irp.f index e1ff305c..73c4cea7 100644 --- a/src/casscf/bielec.irp.f +++ b/src/casscf/bielec.irp.f @@ -10,9 +10,9 @@ BEGIN_PROVIDER [real*8, bielec_PQxx, (mo_num, mo_num,n_core_inact_orb+n_act_orb, bielec_PQxx = 0.d0 do i=1,n_core_inact_orb - ii=list_core(i) + ii=list_core_inact(i) do j=i,n_core_inact_orb - jj=list_core(j) + jj=list_core_inact(j) call get_mo_two_e_integrals_i1j1(ii,jj,mo_num,bielec_PQxx(1,1,i,j),mo_integrals_map) bielec_PQxx(:,:,j,i)=bielec_PQxx(:,:,i,j) end do @@ -56,9 +56,9 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ, (mo_num,n_core_inact_orb+n_act_orb,n_core_i bielec_PxxQ = 0.d0 do i=1,n_core_inact_orb - ii=list_core(i) + ii=list_core_inact(i) do j=i,n_core_inact_orb - jj=list_core(j) + jj=list_core_inact(j) call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array,mo_integrals_map) do p=1,mo_num do q=1,mo_num diff --git a/src/selectors_full/selectors.irp.f b/src/selectors_full/selectors.irp.f index 4e14d65a..0531f731 100644 --- a/src/selectors_full/selectors.irp.f +++ b/src/selectors_full/selectors.irp.f @@ -38,35 +38,18 @@ END_PROVIDER END_DOC integer :: i,k -! if (threshold_selectors == 1.d0) then -! -! do i=1,N_det_selectors -! do k=1,N_int -! psi_selectors(k,1,i) = psi_det(k,1,i) -! psi_selectors(k,2,i) = psi_det(k,2,i) -! enddo -! enddo -! do k=1,N_states -! do i=1,N_det_selectors -! psi_selectors_coef(i,k) = psi_coef(i,k) -! enddo -! enddo -! -! else - + do i=1,N_det_selectors + do k=1,N_int + psi_selectors(k,1,i) = psi_det_sorted(k,1,i) + psi_selectors(k,2,i) = psi_det_sorted(k,2,i) + enddo + enddo + do k=1,N_states do i=1,N_det_selectors - do k=1,N_int - psi_selectors(k,1,i) = psi_det_sorted(k,1,i) - psi_selectors(k,2,i) = psi_det_sorted(k,2,i) - enddo - enddo - do k=1,N_states - do i=1,N_det_selectors - psi_selectors_coef(i,k) = psi_coef_sorted(i,k) - enddo + psi_selectors_coef(i,k) = psi_coef_sorted(i,k) enddo + enddo -! endif END_PROVIDER From 0c2bf90cc521847486d6d1cc9e0f9ffb8aeeef97 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 3 Jul 2019 01:08:48 +0200 Subject: [PATCH 34/59] DGEMM in 4-idx natorb --- src/casscf/bielec.irp.f | 35 ++++----- src/casscf/bielec_natorb.irp.f | 138 +++++++++++++++++++-------------- 2 files changed, 96 insertions(+), 77 deletions(-) diff --git a/src/casscf/bielec.irp.f b/src/casscf/bielec.irp.f index 73c4cea7..2fca1a8c 100644 --- a/src/casscf/bielec.irp.f +++ b/src/casscf/bielec.irp.f @@ -59,9 +59,9 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ, (mo_num,n_core_inact_orb+n_act_orb,n_core_i ii=list_core_inact(i) do j=i,n_core_inact_orb jj=list_core_inact(j) - call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array,mo_integrals_map) - do p=1,mo_num - do q=1,mo_num + call get_mo_two_e_integrals_ij(ii,jj,mo_num,integrals_array,mo_integrals_map) + do q=1,mo_num + do p=1,mo_num bielec_PxxQ(p,i,j,q)=integrals_array(p,q) bielec_PxxQ(p,j,i,q)=integrals_array(q,p) end do @@ -70,9 +70,9 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ, (mo_num,n_core_inact_orb+n_act_orb,n_core_i do j=1,n_act_orb jj=list_act(j) j3=j+n_core_inact_orb - call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array,mo_integrals_map) - do p=1,mo_num - do q=1,mo_num + call get_mo_two_e_integrals_ij(ii,jj,mo_num,integrals_array,mo_integrals_map) + do q=1,mo_num + do p=1,mo_num bielec_PxxQ(p,i,j3,q)=integrals_array(p,q) bielec_PxxQ(p,j3,i,q)=integrals_array(q,p) end do @@ -88,9 +88,9 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ, (mo_num,n_core_inact_orb+n_act_orb,n_core_i do j=i,n_act_orb jj=list_act(j) j3=j+n_core_inact_orb - call get_mo_two_e_integrals_ij (ii,jj,mo_num,integrals_array,mo_integrals_map) - do p=1,mo_num - do q=1,mo_num + call get_mo_two_e_integrals_ij(ii,jj,mo_num,integrals_array,mo_integrals_map) + do q=1,mo_num + do p=1,mo_num bielec_PxxQ(p,i3,j3,q)=integrals_array(p,q) bielec_PxxQ(p,j3,i3,q)=integrals_array(q,p) end do @@ -107,24 +107,19 @@ BEGIN_PROVIDER [real*8, bielecCI, (n_act_orb,n_act_orb,n_act_orb, mo_num)] END_DOC implicit none integer :: i,j,k,p,t,u,v - double precision, allocatable :: integrals_array(:) - real*8 :: mo_two_e_integral + double precision, external :: mo_two_e_integral - allocate(integrals_array(mo_num)) - - do i=1,n_act_orb - t=list_act(i) + do p=1,mo_num do j=1,n_act_orb u=list_act(j) do k=1,n_act_orb v=list_act(k) - ! (tu|vp) - call get_mo_two_e_integrals(t,u,v,mo_num,integrals_array,mo_integrals_map) - do p=1,mo_num - bielecCI(i,k,j,p)=integrals_array(p) + do i=1,n_act_orb + t=list_act(i) + bielecCI(i,k,j,p) = mo_two_e_integral(t,u,v,p) end do end do end do end do END_PROVIDER - + diff --git a/src/casscf/bielec_natorb.irp.f b/src/casscf/bielec_natorb.irp.f index 53d74e14..9826d80c 100644 --- a/src/casscf/bielec_natorb.irp.f +++ b/src/casscf/bielec_natorb.irp.f @@ -1,90 +1,114 @@ - BEGIN_PROVIDER [real*8, bielec_PQxx_no, (mo_num, mo_num,n_core_inact_orb+n_act_orb,n_core_inact_orb+n_act_orb)] + BEGIN_PROVIDER [real*8, bielec_PQxx_no, (mo_num, mo_num,n_core_inact_act_orb,n_core_inact_act_orb)] BEGIN_DOC ! integral (pq|xx) in the basis of natural MOs ! indices are unshifted orbital numbers END_DOC implicit none integer :: i,j,k,l,t,u,p,q,pp - real*8 :: d(n_act_orb) + double precision, allocatable :: f(:,:,:), d(:,:,:) + bielec_PQxx_no(:,:,:,:) = bielec_PQxx(:,:,:,:) - do j=1,mo_num - do k=1,n_core_inact_orb+n_act_orb - do l=1,n_core_inact_orb+n_act_orb + allocate (f(n_act_orb,mo_num,n_core_inact_act_orb), & + d(n_act_orb,mo_num,n_core_inact_act_orb)) + + do l=1,n_core_inact_act_orb + + do k=1,n_core_inact_act_orb + do j=1,mo_num do p=1,n_act_orb - d(p)=0.D0 + f(p,j,k)=bielec_PQxx_no(list_act(p),j,k,l) end do + end do + end do + call dgemm('T','N',n_act_orb,mo_num*n_core_inact_act_orb,n_act_orb,1.d0, & + natorbsCI, size(natorbsCI,1), & + f, n_act_orb, & + 0.d0, & + d, n_act_orb) + do k=1,n_core_inact_act_orb + do j=1,mo_num do p=1,n_act_orb pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=bielec_PQxx_no(list_act(q),j,k,l)*natorbsCI(q,p) - end do + bielec_PQxx_no(list_act(p),j,k,l)=d(pp,j,k) end do + end do + + do j=1,mo_num do p=1,n_act_orb - bielec_PQxx_no(list_act(p),j,k,l)=d(p) + f(p,j,k)=bielec_PQxx_no(j,list_act(p),k,l) + end do + end do + end do + call dgemm('T','N',n_act_orb,mo_num*n_core_inact_act_orb,n_act_orb,1.d0, & + natorbsCI, n_act_orb, & + f, n_act_orb, & + 0.d0, & + d, n_act_orb) + do k=1,n_core_inact_act_orb + do p=1,n_act_orb + pp=n_act_orb-p+1 + do j=1,mo_num + bielec_PQxx_no(j,list_act(p),k,l)=d(pp,j,k) end do end do end do end do - ! 2nd quarter - do j=1,mo_num - do k=1,n_core_inact_orb+n_act_orb - do l=1,n_core_inact_orb+n_act_orb - do p=1,n_act_orb - d(p)=0.D0 + + deallocate (f,d) + + allocate (f(mo_num,mo_num,n_act_orb),d(mo_num,mo_num,n_act_orb)) + + do l=1,n_core_inact_act_orb + + do p=1,n_act_orb + do k=1,mo_num + do j=1,mo_num + f(j,k,p) = bielec_PQxx_no(j,k,n_core_inact_orb+p,l) end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=bielec_PQxx_no(j,list_act(q),k,l)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - bielec_PQxx_no(j,list_act(p),k,l)=d(p) + end do + end do + call dgemm('N','N',mo_num*mo_num,n_act_orb,n_act_orb,1.d0, & + f, mo_num*mo_num, & + natorbsCI, n_act_orb, & + 0.d0, & + d, mo_num*mo_num) + do p=1,n_act_orb + pp=n_act_orb-p+1 + do k=1,mo_num + do j=1,mo_num + bielec_PQxx_no(j,k,n_core_inact_orb+p,l)=d(j,k,pp) end do end do end do end do - ! 3rd quarter - do j=1,mo_num - do k=1,mo_num - do l=1,n_core_inact_orb+n_act_orb - do p=1,n_act_orb - d(p)=0.D0 + + do l=1,n_core_inact_act_orb + do p=1,n_act_orb + do k=1,mo_num + do j=1,mo_num + f(j,k,p) = bielec_PQxx_no(j,k,l,n_core_inact_orb+p) end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=bielec_PQxx_no(j,k,n_core_inact_orb+q,l)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - bielec_PQxx_no(j,k,n_core_inact_orb+p,l)=d(p) - end do - end do - end do - end do - ! 4th quarter - do j=1,mo_num - do k=1,mo_num - do l=1,n_core_inact_orb+n_act_orb - do p=1,n_act_orb - d(p)=0.D0 - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=bielec_PQxx_no(j,k,l,n_core_inact_orb+q)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - bielec_PQxx_no(j,k,l,n_core_inact_orb+p)=d(p) + end do + end do + call dgemm('N','N',mo_num*mo_num,n_act_orb,n_act_orb,1.d0, & + f, mo_num*mo_num, & + natorbsCI, n_act_orb, & + 0.d0, & + d, mo_num*mo_num) + do p=1,n_act_orb + pp=n_act_orb-p+1 + do k=1,mo_num + do j=1,mo_num + bielec_PQxx_no(j,k,l,n_core_inact_orb+p)=d(j,k,pp) end do end do end do end do + deallocate (f,d) + END_PROVIDER From 21dc0f53803d6df767a26d006f65ee570a54a937 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 3 Jul 2019 08:58:30 +0200 Subject: [PATCH 35/59] dgemm --- src/casscf/bielec_natorb.irp.f | 157 +++++++++++++++++++-------------- 1 file changed, 89 insertions(+), 68 deletions(-) diff --git a/src/casscf/bielec_natorb.irp.f b/src/casscf/bielec_natorb.irp.f index 9826d80c..691c7441 100644 --- a/src/casscf/bielec_natorb.irp.f +++ b/src/casscf/bielec_natorb.irp.f @@ -113,88 +113,106 @@ END_PROVIDER -BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_inact_orb+n_act_orb,n_core_inact_orb+n_act_orb, mo_num)] +BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_inact_act_orb,n_core_inact_act_orb, mo_num)] BEGIN_DOC ! integral (px|xq) in the basis of natural MOs ! indices are unshifted orbital numbers END_DOC implicit none integer :: i,j,k,l,t,u,p,q,pp - real*8 :: d(n_act_orb) + double precision, allocatable :: f(:,:,:), d(:,:,:) bielec_PxxQ_no(:,:,:,:) = bielec_PxxQ(:,:,:,:) + allocate (f(n_act_orb,n_core_inact_act_orb,n_core_inact_act_orb), & + d(n_act_orb,n_core_inact_act_orb,n_core_inact_act_orb)) + do j=1,mo_num - do k=1,n_core_inact_orb+n_act_orb - do l=1,n_core_inact_orb+n_act_orb + do l=1,n_core_inact_act_orb + do k=1,n_core_inact_act_orb do p=1,n_act_orb - d(p)=0.D0 + f(p,k,l) = bielec_PxxQ_no(list_act(p),k,l,j) end do + end do + end do + call dgemm('T','N',n_act_orb,n_core_inact_act_orb**2,n_act_orb,1.d0, & + natorbsCI, size(natorbsCI,1), & + f, n_act_orb, & + 0.d0, & + d, n_act_orb) + do l=1,n_core_inact_act_orb + do k=1,n_core_inact_act_orb do p=1,n_act_orb pp=n_act_orb-p+1 + bielec_PxxQ_no(list_act(p),k,l,j)=d(pp,k,l) + end do + end do + end do + end do + + deallocate (f,d) + + allocate (f(n_act_orb,mo_num,n_core_inact_act_orb), & + d(n_act_orb,mo_num,n_core_inact_act_orb)) + + ! 3rd quarter + do k=1,mo_num + do l=1,n_core_inact_act_orb + do j=1,mo_num + do p=1,n_act_orb + f(p,j,l) = bielec_PxxQ_no(j,n_core_inact_orb+p,l,k) + end do + end do + end do + call dgemm('T','N',n_act_orb,mo_num*n_core_inact_act_orb,n_act_orb,1.d0, & + natorbsCI, size(natorbsCI,1), & + f, n_act_orb, & + 0.d0, & + d, n_act_orb) + do l=1,n_core_inact_act_orb + do j=1,mo_num + do p=1,n_act_orb + pp=n_act_orb-p+1 + bielec_PxxQ_no(j,n_core_inact_orb+p,l,k)=d(pp,j,l) + end do + end do + end do + end do + + ! 4th quarter + do k=1,mo_num + do l=1,n_core_inact_act_orb + do j=1,mo_num + do p=1,n_act_orb + d(p,1,1)=0.D0 + end do + do p=1,n_act_orb do q=1,n_act_orb - d(pp)+=bielec_PxxQ_no(list_act(q),k,l,j)*natorbsCI(q,p) + d(p,1,1)+=bielec_PxxQ_no(j,l,n_core_inact_orb+q,k)*natorbsCI(q,p) end do end do do p=1,n_act_orb - bielec_PxxQ_no(list_act(p),k,l,j)=d(p) + pp=n_act_orb-p+1 + bielec_PxxQ_no(j,l,n_core_inact_orb+p,k)=d(pp,1,1) end do end do end do end do ! 2nd quarter - do j=1,mo_num - do k=1,n_core_inact_orb+n_act_orb - do l=1,n_core_inact_orb+n_act_orb + do k=1,n_core_inact_act_orb + do l=1,n_core_inact_act_orb + do j=1,mo_num do p=1,n_act_orb - d(p)=0.D0 + d(p,1,1)=0.D0 end do do p=1,n_act_orb - pp=n_act_orb-p+1 do q=1,n_act_orb - d(pp)+=bielec_PxxQ_no(j,k,l,list_act(q))*natorbsCI(q,p) + d(p,1,1)+=bielec_PxxQ_no(j,k,l,list_act(q))*natorbsCI(q,p) end do end do - do p=1,n_act_orb - bielec_PxxQ_no(j,k,l,list_act(p))=d(p) - end do - end do - end do - end do - ! 3rd quarter - do j=1,mo_num - do k=1,mo_num - do l=1,n_core_inact_orb+n_act_orb - do p=1,n_act_orb - d(p)=0.D0 - end do do p=1,n_act_orb pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=bielec_PxxQ_no(j,n_core_inact_orb+q,l,k)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - bielec_PxxQ_no(j,n_core_inact_orb+p,l,k)=d(p) - end do - end do - end do - end do - ! 4th quarter - do j=1,mo_num - do k=1,mo_num - do l=1,n_core_inact_orb+n_act_orb - do p=1,n_act_orb - d(p)=0.D0 - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - do q=1,n_act_orb - d(pp)+=bielec_PxxQ_no(j,l,n_core_inact_orb+q,k)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - bielec_PxxQ_no(j,l,n_core_inact_orb+p,k)=d(p) + bielec_PxxQ_no(j,k,l,list_act(p))=d(pp,1,1) end do end do end do @@ -210,24 +228,27 @@ BEGIN_PROVIDER [real*8, bielecCI_no, (n_act_orb,n_act_orb,n_act_orb, mo_num)] END_DOC implicit none integer :: i,j,k,l,t,u,p,q,pp - real*8 :: d(n_act_orb) + double precision, allocatable :: f(:,:,:), d(:,:,:) bielecCI_no(:,:,:,:) = bielecCI(:,:,:,:) + allocate (f(n_act_orb,mo_num,n_act_orb), & + d(n_act_orb,mo_num,n_act_orb)) + do j=1,n_act_orb do k=1,n_act_orb do l=1,mo_num do p=1,n_act_orb - d(p)=0.D0 + d(p,1,1)=0.D0 end do do p=1,n_act_orb - pp=n_act_orb-p+1 do q=1,n_act_orb - d(pp)+=bielecCI_no(q,j,k,l)*natorbsCI(q,p) + d(p,1,1)+=bielecCI_no(q,j,k,l)*natorbsCI(q,p) end do end do do p=1,n_act_orb - bielecCI_no(p,j,k,l)=d(p) + pp=n_act_orb-p+1 + bielecCI_no(p,j,k,l)=d(pp,1,1) end do end do end do @@ -237,16 +258,16 @@ BEGIN_PROVIDER [real*8, bielecCI_no, (n_act_orb,n_act_orb,n_act_orb, mo_num)] do k=1,n_act_orb do l=1,mo_num do p=1,n_act_orb - d(p)=0.D0 + d(p,1,1)=0.D0 end do do p=1,n_act_orb - pp=n_act_orb-p+1 do q=1,n_act_orb - d(pp)+=bielecCI_no(j,q,k,l)*natorbsCI(q,p) + d(p,1,1)+=bielecCI_no(j,q,k,l)*natorbsCI(q,p) end do end do do p=1,n_act_orb - bielecCI_no(j,p,k,l)=d(p) + pp=n_act_orb-p+1 + bielecCI_no(j,p,k,l)=d(pp,1,1) end do end do end do @@ -256,16 +277,16 @@ BEGIN_PROVIDER [real*8, bielecCI_no, (n_act_orb,n_act_orb,n_act_orb, mo_num)] do k=1,n_act_orb do l=1,mo_num do p=1,n_act_orb - d(p)=0.D0 + d(p,1,1)=0.D0 end do do p=1,n_act_orb - pp=n_act_orb-p+1 do q=1,n_act_orb - d(pp)+=bielecCI_no(j,k,q,l)*natorbsCI(q,p) + d(p,1,1)+=bielecCI_no(j,k,q,l)*natorbsCI(q,p) end do end do do p=1,n_act_orb - bielecCI_no(j,k,p,l)=d(p) + pp=n_act_orb-p+1 + bielecCI_no(j,k,p,l)=d(pp,1,1) end do end do end do @@ -275,16 +296,16 @@ BEGIN_PROVIDER [real*8, bielecCI_no, (n_act_orb,n_act_orb,n_act_orb, mo_num)] do k=1,n_act_orb do l=1,n_act_orb do p=1,n_act_orb - d(p)=0.D0 + d(p,1,1)=0.D0 end do do p=1,n_act_orb - pp=n_act_orb-p+1 do q=1,n_act_orb - d(pp)+=bielecCI_no(j,k,l,list_act(q))*natorbsCI(q,p) + d(p,1,1)+=bielecCI_no(j,k,l,list_act(q))*natorbsCI(q,p) end do end do do p=1,n_act_orb - bielecCI_no(j,k,l,list_act(p))=d(p) + pp=n_act_orb-p+1 + bielecCI_no(j,k,l,list_act(p))=d(pp,1,1) end do end do end do From 1018c686a9f647af2ce37d33b412955acf8dd2ba Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 3 Jul 2019 20:03:44 +0200 Subject: [PATCH 36/59] dgemm --- src/casscf/bielec_natorb.irp.f | 147 +++++++++++++++++++++++---------- 1 file changed, 104 insertions(+), 43 deletions(-) diff --git a/src/casscf/bielec_natorb.irp.f b/src/casscf/bielec_natorb.irp.f index 691c7441..07836591 100644 --- a/src/casscf/bielec_natorb.irp.f +++ b/src/casscf/bielec_natorb.irp.f @@ -155,7 +155,6 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_inact_act_orb,n_core_inac allocate (f(n_act_orb,mo_num,n_core_inact_act_orb), & d(n_act_orb,mo_num,n_core_inact_act_orb)) - ! 3rd quarter do k=1,mo_num do l=1,n_core_inact_act_orb do j=1,mo_num @@ -179,40 +178,53 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_inact_act_orb,n_core_inac end do end do - ! 4th quarter + deallocate(f,d) + + allocate(f(mo_num,n_core_inact_act_orb,n_act_orb), & + d(mo_num,n_core_inact_act_orb,n_act_orb) ) + do k=1,mo_num - do l=1,n_core_inact_act_orb - do j=1,mo_num - do p=1,n_act_orb - d(p,1,1)=0.D0 + do p=1,n_act_orb + do l=1,n_core_inact_act_orb + do j=1,mo_num + f(j,l,p) = bielec_PxxQ_no(j,l,n_core_inact_orb+p,k) end do - do p=1,n_act_orb - do q=1,n_act_orb - d(p,1,1)+=bielec_PxxQ_no(j,l,n_core_inact_orb+q,k)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - bielec_PxxQ_no(j,l,n_core_inact_orb+p,k)=d(pp,1,1) + end do + end do + call dgemm('N','N',mo_num*n_core_inact_act_orb,n_act_orb,n_act_orb,1.d0, & + f, mo_num*n_core_inact_act_orb, & + natorbsCI, size(natorbsCI,1), & + 0.d0, & + d, mo_num*n_core_inact_act_orb) + do p=1,n_act_orb + pp=n_act_orb-p+1 + do l=1,n_core_inact_act_orb + do j=1,mo_num + bielec_PxxQ_no(j,l,n_core_inact_orb+p,k)=d(j,l,pp) end do end do end do end do - ! 2nd quarter - do k=1,n_core_inact_act_orb - do l=1,n_core_inact_act_orb - do j=1,mo_num - do p=1,n_act_orb - d(p,1,1)=0.D0 + + + do l=1,n_core_inact_act_orb + do p=1,n_act_orb + do k=1,n_core_inact_act_orb + do j=1,mo_num + f(j,k,p) = bielec_PxxQ_no(j,k,l,n_core_inact_orb+p) end do - do p=1,n_act_orb - do q=1,n_act_orb - d(p,1,1)+=bielec_PxxQ_no(j,k,l,list_act(q))*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - bielec_PxxQ_no(j,k,l,list_act(p))=d(pp,1,1) + end do + end do + call dgemm('N','N',mo_num*n_core_inact_act_orb,n_act_orb,n_act_orb,1.d0, & + f, mo_num*n_core_inact_act_orb, & + natorbsCI, size(natorbsCI,1), & + 0.d0, & + d, mo_num*n_core_inact_act_orb) + do p=1,n_act_orb + pp=n_act_orb-p+1 + do k=1,n_core_inact_act_orb + do j=1,mo_num + bielec_PxxQ_no(j,k,l,n_core_inact_orb+p)=d(j,k,pp) end do end do end do @@ -232,28 +244,32 @@ BEGIN_PROVIDER [real*8, bielecCI_no, (n_act_orb,n_act_orb,n_act_orb, mo_num)] bielecCI_no(:,:,:,:) = bielecCI(:,:,:,:) - allocate (f(n_act_orb,mo_num,n_act_orb), & - d(n_act_orb,mo_num,n_act_orb)) + allocate (f(n_act_orb,n_act_orb,mo_num), & + d(n_act_orb,n_act_orb,mo_num)) - do j=1,n_act_orb + do l=1,mo_num do k=1,n_act_orb - do l=1,mo_num + do j=1,n_act_orb do p=1,n_act_orb - d(p,1,1)=0.D0 - end do - do p=1,n_act_orb - do q=1,n_act_orb - d(p,1,1)+=bielecCI_no(q,j,k,l)*natorbsCI(q,p) - end do + f(p,j,k)=bielecCI_no(p,j,k,l) end do + end do + end do + call dgemm('T','N',n_act_orb,n_act_orb*n_act_orb,n_act_orb,1.d0, & + natorbsCI, size(natorbsCI,1), & + f, n_act_orb, & + 0.d0, & + d, n_act_orb) + do k=1,n_act_orb + do j=1,n_act_orb do p=1,n_act_orb pp=n_act_orb-p+1 - bielecCI_no(p,j,k,l)=d(pp,1,1) + bielecCI_no(p,j,k,l)=d(pp,j,k) end do end do end do end do - ! 2nd quarter + do j=1,n_act_orb do k=1,n_act_orb do l=1,mo_num @@ -291,10 +307,55 @@ BEGIN_PROVIDER [real*8, bielecCI_no, (n_act_orb,n_act_orb,n_act_orb, mo_num)] end do end do end do - ! 4th quarter - do j=1,n_act_orb + +! do l=1,mo_num +! do k=1,n_act_orb +! do p=1,n_act_orb +! do j=1,n_act_orb +! f(j,p,k)=bielecCI_no(j,p,k,l) +! end do +! end do +! end do +! call dgemm('T','N',n_act_orb,n_act_orb*n_act_orb,n_act_orb,1.d0, & +! natorbsCI, n_act_orb, & +! f, n_act_orb, & +! 0.d0, & +! d, n_act_orb) +! do k=1,n_act_orb +! do p=1,n_act_orb +! pp=n_act_orb-p+1 +! do j=1,n_act_orb +! bielecCI_no(j,p,k,l)=d(j,pp,k) +! end do +! end do +! end do +! +! do p=1,n_act_orb +! do k=1,n_act_orb +! do j=1,n_act_orb +! f(j,k,p)=bielecCI_no(j,k,p,l) +! end do +! end do +! end do +! call dgemm('N','N',n_act_orb*n_act_orb,n_act_orb,n_act_orb,1.d0, & +! f, n_act_orb*n_act_orb, & +! natorbsCI, n_act_orb, & +! 0.d0, & +! d, n_act_orb*n_act_orb) +! +! do p=1,n_act_orb +! pp=n_act_orb-p+1 +! do k=1,n_act_orb +! do j=1,n_act_orb +! bielecCI_no(j,k,p,l)=d(j,k,pp) +! end do +! end do +! end do +! end do +! + do l=1,n_act_orb do k=1,n_act_orb - do l=1,n_act_orb + do j=1,n_act_orb do p=1,n_act_orb d(p,1,1)=0.D0 end do From 721f5a662b2ed4bc05a9a8c46a921b28d41cd3bd Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 3 Jul 2019 21:38:40 +0200 Subject: [PATCH 37/59] OpenMP in 4idx --- src/casscf/bielec_natorb.irp.f | 193 +++++++++++++++++---------------- 1 file changed, 99 insertions(+), 94 deletions(-) diff --git a/src/casscf/bielec_natorb.irp.f b/src/casscf/bielec_natorb.irp.f index 07836591..cb09be3e 100644 --- a/src/casscf/bielec_natorb.irp.f +++ b/src/casscf/bielec_natorb.irp.f @@ -8,12 +8,18 @@ double precision, allocatable :: f(:,:,:), d(:,:,:) - bielec_PQxx_no(:,:,:,:) = bielec_PQxx(:,:,:,:) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(j,k,l,p,pp,d,f) & + !$OMP SHARED(n_core_inact_act_orb,mo_num,n_act_orb,n_core_inact_orb, & + !$OMP bielec_PQxx_no,bielec_PQxx,list_act,natorbsCI) allocate (f(n_act_orb,mo_num,n_core_inact_act_orb), & d(n_act_orb,mo_num,n_core_inact_act_orb)) + !$OMP DO do l=1,n_core_inact_act_orb + bielec_PQxx_no(:,:,:,l) = bielec_PQxx(:,:,:,l) do k=1,n_core_inact_act_orb do j=1,mo_num @@ -55,11 +61,13 @@ end do end do end do + !$OMP END DO NOWAIT deallocate (f,d) allocate (f(mo_num,mo_num,n_act_orb),d(mo_num,mo_num,n_act_orb)) + !$OMP DO do l=1,n_core_inact_act_orb do p=1,n_act_orb @@ -83,7 +91,11 @@ end do end do end do + !$OMP END DO NOWAIT + !$OMP BARRIER + + !$OMP DO do l=1,n_core_inact_act_orb do p=1,n_act_orb do k=1,mo_num @@ -106,8 +118,10 @@ end do end do end do + !$OMP END DO deallocate (f,d) + !$OMP END PARALLEL END_PROVIDER @@ -122,12 +136,18 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_inact_act_orb,n_core_inac integer :: i,j,k,l,t,u,p,q,pp double precision, allocatable :: f(:,:,:), d(:,:,:) - bielec_PxxQ_no(:,:,:,:) = bielec_PxxQ(:,:,:,:) + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(j,k,l,p,pp,d,f) & + !$OMP SHARED(n_core_inact_act_orb,mo_num,n_act_orb,n_core_inact_orb, & + !$OMP bielec_PxxQ_no,bielec_PxxQ,list_act,natorbsCI) + allocate (f(n_act_orb,n_core_inact_act_orb,n_core_inact_act_orb), & d(n_act_orb,n_core_inact_act_orb,n_core_inact_act_orb)) + !$OMP DO do j=1,mo_num + bielec_PxxQ_no(:,:,:,j) = bielec_PxxQ(:,:,:,j) do l=1,n_core_inact_act_orb do k=1,n_core_inact_act_orb do p=1,n_act_orb @@ -149,12 +169,14 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_inact_act_orb,n_core_inac end do end do end do + !$OMP END DO NOWAIT deallocate (f,d) allocate (f(n_act_orb,mo_num,n_core_inact_act_orb), & d(n_act_orb,mo_num,n_core_inact_act_orb)) + !$OMP DO do k=1,mo_num do l=1,n_core_inact_act_orb do j=1,mo_num @@ -177,12 +199,14 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_inact_act_orb,n_core_inac end do end do end do + !$OMP END DO NOWAIT deallocate(f,d) allocate(f(mo_num,n_core_inact_act_orb,n_act_orb), & d(mo_num,n_core_inact_act_orb,n_act_orb) ) + !$OMP DO do k=1,mo_num do p=1,n_act_orb do l=1,n_core_inact_act_orb @@ -205,8 +229,11 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_inact_act_orb,n_core_inac end do end do end do + !$OMP END DO NOWAIT + !$OMP BARRIER + !$OMP DO do l=1,n_core_inact_act_orb do p=1,n_act_orb do k=1,n_core_inact_act_orb @@ -229,6 +256,9 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_inact_act_orb,n_core_inac end do end do end do + !$OMP END DO NOWAIT + deallocate(f,d) + !$OMP END PARALLEL END_PROVIDER @@ -242,12 +272,17 @@ BEGIN_PROVIDER [real*8, bielecCI_no, (n_act_orb,n_act_orb,n_act_orb, mo_num)] integer :: i,j,k,l,t,u,p,q,pp double precision, allocatable :: f(:,:,:), d(:,:,:) - bielecCI_no(:,:,:,:) = bielecCI(:,:,:,:) + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(j,k,l,p,pp,d,f) & + !$OMP SHARED(n_core_inact_act_orb,mo_num,n_act_orb,n_core_inact_orb, & + !$OMP bielecCI_no,bielecCI,list_act,natorbsCI) allocate (f(n_act_orb,n_act_orb,mo_num), & d(n_act_orb,n_act_orb,mo_num)) + !$OMP DO do l=1,mo_num + bielecCI_no(:,:,:,l) = bielecCI(:,:,:,l) do k=1,n_act_orb do j=1,n_act_orb do p=1,n_act_orb @@ -267,110 +302,80 @@ BEGIN_PROVIDER [real*8, bielecCI_no, (n_act_orb,n_act_orb,n_act_orb, mo_num)] bielecCI_no(p,j,k,l)=d(pp,j,k) end do end do - end do - end do - do j=1,n_act_orb - do k=1,n_act_orb - do l=1,mo_num + do j=1,n_act_orb do p=1,n_act_orb - d(p,1,1)=0.D0 - end do - do p=1,n_act_orb - do q=1,n_act_orb - d(p,1,1)+=bielecCI_no(j,q,k,l)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - bielecCI_no(j,p,k,l)=d(pp,1,1) + f(p,j,k)=bielecCI_no(j,p,k,l) end do end do end do - end do - ! 3rd quarter - do j=1,n_act_orb + call dgemm('T','N',n_act_orb,n_act_orb*n_act_orb,n_act_orb,1.d0, & + natorbsCI, n_act_orb, & + f, n_act_orb, & + 0.d0, & + d, n_act_orb) do k=1,n_act_orb - do l=1,mo_num - do p=1,n_act_orb - d(p,1,1)=0.D0 + do p=1,n_act_orb + pp=n_act_orb-p+1 + do j=1,n_act_orb + bielecCI_no(j,p,k,l)=d(pp,j,k) end do - do p=1,n_act_orb - do q=1,n_act_orb - d(p,1,1)+=bielecCI_no(j,k,q,l)*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - bielecCI_no(j,k,p,l)=d(pp,1,1) - end do - end do - end do - end do + end do + end do -! do l=1,mo_num -! do k=1,n_act_orb -! do p=1,n_act_orb -! do j=1,n_act_orb -! f(j,p,k)=bielecCI_no(j,p,k,l) -! end do -! end do -! end do -! call dgemm('T','N',n_act_orb,n_act_orb*n_act_orb,n_act_orb,1.d0, & -! natorbsCI, n_act_orb, & -! f, n_act_orb, & -! 0.d0, & -! d, n_act_orb) -! do k=1,n_act_orb -! do p=1,n_act_orb -! pp=n_act_orb-p+1 -! do j=1,n_act_orb -! bielecCI_no(j,p,k,l)=d(j,pp,k) -! end do -! end do -! end do -! -! do p=1,n_act_orb -! do k=1,n_act_orb -! do j=1,n_act_orb -! f(j,k,p)=bielecCI_no(j,k,p,l) -! end do -! end do -! end do -! call dgemm('N','N',n_act_orb*n_act_orb,n_act_orb,n_act_orb,1.d0, & -! f, n_act_orb*n_act_orb, & -! natorbsCI, n_act_orb, & -! 0.d0, & -! d, n_act_orb*n_act_orb) -! -! do p=1,n_act_orb -! pp=n_act_orb-p+1 -! do k=1,n_act_orb -! do j=1,n_act_orb -! bielecCI_no(j,k,p,l)=d(j,k,pp) -! end do -! end do -! end do -! end do -! - do l=1,n_act_orb - do k=1,n_act_orb - do j=1,n_act_orb - do p=1,n_act_orb - d(p,1,1)=0.D0 + do p=1,n_act_orb + do k=1,n_act_orb + do j=1,n_act_orb + f(j,k,p)=bielecCI_no(j,k,p,l) end do - do p=1,n_act_orb - do q=1,n_act_orb - d(p,1,1)+=bielecCI_no(j,k,l,list_act(q))*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - pp=n_act_orb-p+1 - bielecCI_no(j,k,l,list_act(p))=d(pp,1,1) + end do + end do + call dgemm('N','N',n_act_orb*n_act_orb,n_act_orb,n_act_orb,1.d0, & + f, n_act_orb*n_act_orb, & + natorbsCI, n_act_orb, & + 0.d0, & + d, n_act_orb*n_act_orb) + + do p=1,n_act_orb + pp=n_act_orb-p+1 + do k=1,n_act_orb + do j=1,n_act_orb + bielecCI_no(j,k,p,l)=d(j,k,pp) end do end do end do end do + !$OMP END DO + + !$OMP DO + do l=1,n_act_orb + do p=1,n_act_orb + do k=1,n_act_orb + do j=1,n_act_orb + f(j,k,p)=bielecCI_no(j,k,l,list_act(p)) + end do + end do + end do + call dgemm('N','N',n_act_orb*n_act_orb,n_act_orb,n_act_orb,1.d0, & + f, n_act_orb*n_act_orb, & + natorbsCI, n_act_orb, & + 0.d0, & + d, n_act_orb*n_act_orb) + + do p=1,n_act_orb + pp=n_act_orb-p+1 + do k=1,n_act_orb + do j=1,n_act_orb + bielecCI_no(j,k,l,list_act(p))=d(j,k,pp) + end do + end do + end do + end do + !$OMP END DO + + deallocate(d,f) + !$OMP END PARALLEL + END_PROVIDER From 62ef1526a2b62addec421949f45b79f7f857617a Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Wed, 3 Jul 2019 21:48:01 +0200 Subject: [PATCH 38/59] OpenMP in bielec construction --- src/casscf/bielec.irp.f | 41 ++++++++++++++++++++++++++++++++++++----- 1 file changed, 36 insertions(+), 5 deletions(-) diff --git a/src/casscf/bielec.irp.f b/src/casscf/bielec.irp.f index 2fca1a8c..daf3f68b 100644 --- a/src/casscf/bielec.irp.f +++ b/src/casscf/bielec.irp.f @@ -1,4 +1,4 @@ -BEGIN_PROVIDER [real*8, bielec_PQxx, (mo_num, mo_num,n_core_inact_orb+n_act_orb,n_core_inact_orb+n_act_orb)] +BEGIN_PROVIDER [real*8, bielec_PQxx, (mo_num, mo_num,n_core_inact_act_orb,n_core_inact_act_orb)] BEGIN_DOC ! bielec_PQxx : integral (pq|xx) with p,q arbitrary, x core or active ! indices are unshifted orbital numbers @@ -7,8 +7,15 @@ BEGIN_PROVIDER [real*8, bielec_PQxx, (mo_num, mo_num,n_core_inact_orb+n_act_orb, integer :: i,j,ii,jj,p,q,i3,j3,t3,v3 real*8 :: mo_two_e_integral - bielec_PQxx = 0.d0 + bielec_PQxx(:,:,:,:) = 0.d0 + PROVIDE mo_two_e_integrals_in_map + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i,ii,j,jj,i3,j3) & + !$OMP SHARED(n_core_inact_orb,list_core_inact,mo_num,bielec_PQxx, & + !$OMP n_act_orb,mo_integrals_map,list_act) + + !$OMP DO do i=1,n_core_inact_orb ii=list_core_inact(i) do j=i,n_core_inact_orb @@ -23,9 +30,10 @@ BEGIN_PROVIDER [real*8, bielec_PQxx, (mo_num, mo_num,n_core_inact_orb+n_act_orb, bielec_PQxx(:,:,j3,i)=bielec_PQxx(:,:,i,j3) end do end do + !$OMP END DO - ! (ij|pq) + !$OMP DO do i=1,n_act_orb ii=list_act(i) i3=i+n_core_inact_orb @@ -36,6 +44,9 @@ BEGIN_PROVIDER [real*8, bielec_PQxx, (mo_num, mo_num,n_core_inact_orb+n_act_orb, bielec_PQxx(:,:,j3,i3)=bielec_PQxx(:,:,i3,j3) end do end do + !$OMP END DO + + !$OMP END PARALLEL END_PROVIDER @@ -51,10 +62,17 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ, (mo_num,n_core_inact_orb+n_act_orb,n_core_i double precision, allocatable :: integrals_array(:,:) real*8 :: mo_two_e_integral + PROVIDE mo_two_e_integrals_in_map + bielec_PxxQ = 0.d0 + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP PRIVATE(i,ii,j,jj,i3,j3,integrals_array) & + !$OMP SHARED(n_core_inact_orb,list_core_inact,mo_num,bielec_PxxQ, & + !$OMP n_act_orb,mo_integrals_map,list_act) + allocate(integrals_array(mo_num,mo_num)) - bielec_PxxQ = 0.d0 - + !$OMP DO do i=1,n_core_inact_orb ii=list_core_inact(i) do j=i,n_core_inact_orb @@ -79,9 +97,11 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ, (mo_num,n_core_inact_orb+n_act_orb,n_core_i end do end do end do + !$OMP END DO ! (ip|qj) + !$OMP DO do i=1,n_act_orb ii=list_act(i) i3=i+n_core_inact_orb @@ -97,6 +117,11 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ, (mo_num,n_core_inact_orb+n_act_orb,n_core_i end do end do end do + !$OMP END DO + + deallocate(integrals_array) + !$OMP END PARALLEL + END_PROVIDER @@ -108,7 +133,11 @@ BEGIN_PROVIDER [real*8, bielecCI, (n_act_orb,n_act_orb,n_act_orb, mo_num)] implicit none integer :: i,j,k,p,t,u,v double precision, external :: mo_two_e_integral + PROVIDE mo_two_e_integrals_in_map + !$OMP PARALLEL DO DEFAULT(NONE) & + !$OMP PRIVATE(i,j,k,p,t,u,v) & + !$OMP SHARED(mo_num,n_act_orb,list_act,bielecCI) do p=1,mo_num do j=1,n_act_orb u=list_act(j) @@ -121,5 +150,7 @@ BEGIN_PROVIDER [real*8, bielecCI, (n_act_orb,n_act_orb,n_act_orb, mo_num)] end do end do end do + !$OMP END PARALLEL DO + END_PROVIDER From 932befb2bb528c87d367b9d4aab6c1300b4e66aa Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Thu, 4 Jul 2019 00:22:44 +0200 Subject: [PATCH 39/59] Properly ordered natural MOs --- src/casscf/bavard.irp.f | 4 +-- src/casscf/bielec.irp.f | 2 +- src/casscf/bielec_natorb.irp.f | 48 +++++++++++++--------------------- src/casscf/casscf.irp.f | 1 + src/casscf/natorb.irp.f | 38 +++++++++++++-------------- 5 files changed, 41 insertions(+), 52 deletions(-) diff --git a/src/casscf/bavard.irp.f b/src/casscf/bavard.irp.f index 402e67ec..a9797712 100644 --- a/src/casscf/bavard.irp.f +++ b/src/casscf/bavard.irp.f @@ -1,6 +1,6 @@ ! -*- F90 -*- BEGIN_PROVIDER [logical, bavard] -! bavard=.true. - bavard=.false. + bavard=.true. +! bavard=.false. END_PROVIDER diff --git a/src/casscf/bielec.irp.f b/src/casscf/bielec.irp.f index daf3f68b..1c6d9e6b 100644 --- a/src/casscf/bielec.irp.f +++ b/src/casscf/bielec.irp.f @@ -52,7 +52,7 @@ END_PROVIDER -BEGIN_PROVIDER [real*8, bielec_PxxQ, (mo_num,n_core_inact_orb+n_act_orb,n_core_inact_orb+n_act_orb, mo_num)] +BEGIN_PROVIDER [real*8, bielec_PxxQ, (mo_num,n_core_inact_act_orb,n_core_inact_act_orb, mo_num)] BEGIN_DOC ! bielec_PxxQ : integral (px|xq) with p,q arbitrary, x core or active ! indices are unshifted orbital numbers diff --git a/src/casscf/bielec_natorb.irp.f b/src/casscf/bielec_natorb.irp.f index cb09be3e..9968530c 100644 --- a/src/casscf/bielec_natorb.irp.f +++ b/src/casscf/bielec_natorb.irp.f @@ -4,13 +4,13 @@ ! indices are unshifted orbital numbers END_DOC implicit none - integer :: i,j,k,l,t,u,p,q,pp + integer :: i,j,k,l,t,u,p,q double precision, allocatable :: f(:,:,:), d(:,:,:) !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(j,k,l,p,pp,d,f) & + !$OMP PRIVATE(j,k,l,p,d,f) & !$OMP SHARED(n_core_inact_act_orb,mo_num,n_act_orb,n_core_inact_orb, & !$OMP bielec_PQxx_no,bielec_PQxx,list_act,natorbsCI) @@ -36,8 +36,7 @@ do k=1,n_core_inact_act_orb do j=1,mo_num do p=1,n_act_orb - pp=n_act_orb-p+1 - bielec_PQxx_no(list_act(p),j,k,l)=d(pp,j,k) + bielec_PQxx_no(list_act(p),j,k,l)=d(p,j,k) end do end do @@ -54,9 +53,8 @@ d, n_act_orb) do k=1,n_core_inact_act_orb do p=1,n_act_orb - pp=n_act_orb-p+1 do j=1,mo_num - bielec_PQxx_no(j,list_act(p),k,l)=d(pp,j,k) + bielec_PQxx_no(j,list_act(p),k,l)=d(p,j,k) end do end do end do @@ -83,10 +81,9 @@ 0.d0, & d, mo_num*mo_num) do p=1,n_act_orb - pp=n_act_orb-p+1 do k=1,mo_num do j=1,mo_num - bielec_PQxx_no(j,k,n_core_inact_orb+p,l)=d(j,k,pp) + bielec_PQxx_no(j,k,n_core_inact_orb+p,l)=d(j,k,p) end do end do end do @@ -110,10 +107,9 @@ 0.d0, & d, mo_num*mo_num) do p=1,n_act_orb - pp=n_act_orb-p+1 do k=1,mo_num do j=1,mo_num - bielec_PQxx_no(j,k,l,n_core_inact_orb+p)=d(j,k,pp) + bielec_PQxx_no(j,k,l,n_core_inact_orb+p)=d(j,k,p) end do end do end do @@ -133,11 +129,11 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_inact_act_orb,n_core_inac ! indices are unshifted orbital numbers END_DOC implicit none - integer :: i,j,k,l,t,u,p,q,pp + integer :: i,j,k,l,t,u,p,q double precision, allocatable :: f(:,:,:), d(:,:,:) !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(j,k,l,p,pp,d,f) & + !$OMP PRIVATE(j,k,l,p,d,f) & !$OMP SHARED(n_core_inact_act_orb,mo_num,n_act_orb,n_core_inact_orb, & !$OMP bielec_PxxQ_no,bielec_PxxQ,list_act,natorbsCI) @@ -163,8 +159,7 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_inact_act_orb,n_core_inac do l=1,n_core_inact_act_orb do k=1,n_core_inact_act_orb do p=1,n_act_orb - pp=n_act_orb-p+1 - bielec_PxxQ_no(list_act(p),k,l,j)=d(pp,k,l) + bielec_PxxQ_no(list_act(p),k,l,j)=d(p,k,l) end do end do end do @@ -193,8 +188,7 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_inact_act_orb,n_core_inac do l=1,n_core_inact_act_orb do j=1,mo_num do p=1,n_act_orb - pp=n_act_orb-p+1 - bielec_PxxQ_no(j,n_core_inact_orb+p,l,k)=d(pp,j,l) + bielec_PxxQ_no(j,n_core_inact_orb+p,l,k)=d(p,j,l) end do end do end do @@ -221,10 +215,9 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_inact_act_orb,n_core_inac 0.d0, & d, mo_num*n_core_inact_act_orb) do p=1,n_act_orb - pp=n_act_orb-p+1 do l=1,n_core_inact_act_orb do j=1,mo_num - bielec_PxxQ_no(j,l,n_core_inact_orb+p,k)=d(j,l,pp) + bielec_PxxQ_no(j,l,n_core_inact_orb+p,k)=d(j,l,p) end do end do end do @@ -248,10 +241,9 @@ BEGIN_PROVIDER [real*8, bielec_PxxQ_no, (mo_num,n_core_inact_act_orb,n_core_inac 0.d0, & d, mo_num*n_core_inact_act_orb) do p=1,n_act_orb - pp=n_act_orb-p+1 do k=1,n_core_inact_act_orb do j=1,mo_num - bielec_PxxQ_no(j,k,l,n_core_inact_orb+p)=d(j,k,pp) + bielec_PxxQ_no(j,k,l,n_core_inact_orb+p)=d(j,k,p) end do end do end do @@ -269,11 +261,11 @@ BEGIN_PROVIDER [real*8, bielecCI_no, (n_act_orb,n_act_orb,n_act_orb, mo_num)] ! index p runs over the whole basis, t,u,v only over the active orbitals END_DOC implicit none - integer :: i,j,k,l,t,u,p,q,pp + integer :: i,j,k,l,t,u,p,q double precision, allocatable :: f(:,:,:), d(:,:,:) !$OMP PARALLEL DEFAULT(NONE) & - !$OMP PRIVATE(j,k,l,p,pp,d,f) & + !$OMP PRIVATE(j,k,l,p,d,f) & !$OMP SHARED(n_core_inact_act_orb,mo_num,n_act_orb,n_core_inact_orb, & !$OMP bielecCI_no,bielecCI,list_act,natorbsCI) @@ -298,8 +290,7 @@ BEGIN_PROVIDER [real*8, bielecCI_no, (n_act_orb,n_act_orb,n_act_orb, mo_num)] do k=1,n_act_orb do j=1,n_act_orb do p=1,n_act_orb - pp=n_act_orb-p+1 - bielecCI_no(p,j,k,l)=d(pp,j,k) + bielecCI_no(p,j,k,l)=d(p,j,k) end do end do @@ -316,9 +307,8 @@ BEGIN_PROVIDER [real*8, bielecCI_no, (n_act_orb,n_act_orb,n_act_orb, mo_num)] d, n_act_orb) do k=1,n_act_orb do p=1,n_act_orb - pp=n_act_orb-p+1 do j=1,n_act_orb - bielecCI_no(j,p,k,l)=d(pp,j,k) + bielecCI_no(j,p,k,l)=d(p,j,k) end do end do end do @@ -337,10 +327,9 @@ BEGIN_PROVIDER [real*8, bielecCI_no, (n_act_orb,n_act_orb,n_act_orb, mo_num)] d, n_act_orb*n_act_orb) do p=1,n_act_orb - pp=n_act_orb-p+1 do k=1,n_act_orb do j=1,n_act_orb - bielecCI_no(j,k,p,l)=d(j,k,pp) + bielecCI_no(j,k,p,l)=d(j,k,p) end do end do end do @@ -363,10 +352,9 @@ BEGIN_PROVIDER [real*8, bielecCI_no, (n_act_orb,n_act_orb,n_act_orb, mo_num)] d, n_act_orb*n_act_orb) do p=1,n_act_orb - pp=n_act_orb-p+1 do k=1,n_act_orb do j=1,n_act_orb - bielecCI_no(j,k,l,list_act(p))=d(j,k,pp) + bielecCI_no(j,k,l,list_act(p))=d(j,k,p) end do end do end do diff --git a/src/casscf/casscf.irp.f b/src/casscf/casscf.irp.f index 4270a9fb..1b77cf43 100644 --- a/src/casscf/casscf.irp.f +++ b/src/casscf/casscf.irp.f @@ -32,6 +32,7 @@ subroutine run converged = dabs(energy_improvement) < thresh_scf pt2_max = dabs(energy_improvement / pt2_relative_error) + call update_integrals mo_coef = NewOrbs call save_mos call map_deinit(mo_integrals_map) diff --git a/src/casscf/natorb.irp.f b/src/casscf/natorb.irp.f index dcbcd413..c84b4862 100644 --- a/src/casscf/natorb.irp.f +++ b/src/casscf/natorb.irp.f @@ -11,7 +11,7 @@ end do do i=1,n_act_orb - occnum(list_act(i))=occ_act(n_act_orb-i+1) + occnum(list_act(i))=occ_act(i) end do if (bavard) then @@ -31,8 +31,10 @@ END_PROVIDER ! Natural orbitals of CI END_DOC integer :: i, j + double precision :: Vt(n_act_orb,n_act_orb) - call lapack_diag(occ_act,natorbsCI,D0tu,n_act_orb,n_act_orb) +! call lapack_diag(occ_act,natorbsCI,D0tu,n_act_orb,n_act_orb) + call svd(D0tu, size(D0tu,1), natorbsCI,size(natorbsCI,1), occ_act, Vt, size(Vt,1),n_act_orb,n_act_orb) if (bavard) then write(6,*) ' found occupation numbers as ' @@ -70,7 +72,7 @@ BEGIN_PROVIDER [real*8, P0tuvx_no, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] BEGIN_DOC ! 4-index transformation of 2part matrices END_DOC - integer :: i,j,k,l,p,q,pp + integer :: i,j,k,l,p,q real*8 :: d(n_act_orb) ! index per index @@ -84,9 +86,8 @@ BEGIN_PROVIDER [real*8, P0tuvx_no, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] d(p)=0.D0 end do do p=1,n_act_orb - pp=n_act_orb-p+1 do q=1,n_act_orb - d(pp)+=P0tuvx_no(q,j,k,l)*natorbsCI(q,p) + d(p)+=P0tuvx_no(q,j,k,l)*natorbsCI(q,p) end do end do do p=1,n_act_orb @@ -103,9 +104,8 @@ BEGIN_PROVIDER [real*8, P0tuvx_no, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] d(p)=0.D0 end do do p=1,n_act_orb - pp=n_act_orb-p+1 do q=1,n_act_orb - d(pp)+=P0tuvx_no(j,q,k,l)*natorbsCI(q,p) + d(p)+=P0tuvx_no(j,q,k,l)*natorbsCI(q,p) end do end do do p=1,n_act_orb @@ -122,9 +122,8 @@ BEGIN_PROVIDER [real*8, P0tuvx_no, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] d(p)=0.D0 end do do p=1,n_act_orb - pp=n_act_orb-p+1 do q=1,n_act_orb - d(pp)+=P0tuvx_no(j,k,q,l)*natorbsCI(q,p) + d(p)+=P0tuvx_no(j,k,q,l)*natorbsCI(q,p) end do end do do p=1,n_act_orb @@ -141,9 +140,8 @@ BEGIN_PROVIDER [real*8, P0tuvx_no, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] d(p)=0.D0 end do do p=1,n_act_orb - pp=n_act_orb-p+1 do q=1,n_act_orb - d(pp)+=P0tuvx_no(j,k,l,q)*natorbsCI(q,p) + d(p)+=P0tuvx_no(j,k,l,q)*natorbsCI(q,p) end do end do do p=1,n_act_orb @@ -162,7 +160,7 @@ BEGIN_PROVIDER [real*8, one_ints_no, (mo_num,mo_num)] BEGIN_DOC ! Transformed one-e integrals END_DOC - integer :: i,j, p, pp, q + integer :: i,j, p, q real*8 :: d(n_act_orb) one_ints_no(:,:)=mo_one_e_integrals(:,:) @@ -172,9 +170,8 @@ BEGIN_PROVIDER [real*8, one_ints_no, (mo_num,mo_num)] d(p)=0.D0 end do do p=1,n_act_orb - pp=n_act_orb-p+1 do q=1,n_act_orb - d(pp)+=one_ints_no(list_act(q),j)*natorbsCI(q,p) + d(p)+=one_ints_no(list_act(q),j)*natorbsCI(q,p) end do end do do p=1,n_act_orb @@ -188,9 +185,8 @@ BEGIN_PROVIDER [real*8, one_ints_no, (mo_num,mo_num)] d(p)=0.D0 end do do p=1,n_act_orb - pp=n_act_orb-p+1 do q=1,n_act_orb - d(pp)+=one_ints_no(j,list_act(q))*natorbsCI(q,p) + d(p)+=one_ints_no(j,list_act(q))*natorbsCI(q,p) end do end do do p=1,n_act_orb @@ -205,7 +201,7 @@ BEGIN_PROVIDER [real*8, NatOrbsFCI, (ao_num,mo_num)] BEGIN_DOC ! FCI natural orbitals END_DOC - integer :: i,j, p, pp, q + integer :: i,j, p, q real*8 :: d(n_act_orb) NatOrbsFCI(:,:)=mo_coef(:,:) @@ -215,14 +211,18 @@ BEGIN_PROVIDER [real*8, NatOrbsFCI, (ao_num,mo_num)] d(p)=0.D0 end do do p=1,n_act_orb - pp=n_act_orb-p+1 do q=1,n_act_orb - d(pp)+=NatOrbsFCI(j,list_act(q))*natorbsCI(q,p) + d(p)+=NatOrbsFCI(j,list_act(q))*natorbsCI(q,p) end do end do do p=1,n_act_orb NatOrbsFCI(j,list_act(p))=d(p) end do end do + +! call dgemm('N','T', ao_num,mo_num,mo_num,1.d0, & +! NatOrbsFCI, size(NatOrbsFCI,1), & +! Umat, size(Umat,1), 0.d0, & +! NewOrbs, size(NewOrbs,1)) END_PROVIDER From 55286d7889d488fa3d2ad4dce5d883e355aacc9a Mon Sep 17 00:00:00 2001 From: Emmanuel Giner LCT Date: Thu, 4 Jul 2019 00:40:02 +0200 Subject: [PATCH 40/59] improvement in casscf with CISD, CISDTQ and so on --- src/casscf/EZFIO.cfg | 6 + src/casscf/NEED | 2 +- src/casscf/casscf.irp.f | 121 +++++++++++++------- src/casscf/change_bitmasks.irp.f | 14 +++ src/casscf/cipsi_routines.irp.f | 72 ++++++++++++ src/casscf/cisd_routine.irp.f | 64 +++++++++++ src/casscf/cisdtq_routine.irp.f | 47 ++++++++ src/casscf/gradient.irp.f | 4 +- src/casscf/h_apply.irp.f | 18 +++ src/casscf/neworbs.irp.f | 5 +- src/cisd/cisd.irp.f | 32 +----- src/cisd/cisd_routine.irp.f | 42 +++++++ src/generators_fluid/NEED | 1 + src/generators_fluid/README.rst | 0 src/generators_fluid/extract_cas.irp.f | 23 ++++ src/generators_fluid/generators.irp.f | 101 ++++++++++++++++ src/generators_fluid/generators_cas.irp.f | 69 +++++++++++ src/generators_fluid/generators_hf.irp.f | 51 +++++++++ src/generators_fluid/generators_hf_sd.irp.f | 80 +++++++++++++ src/two_body_rdm/orb_range_2_rdm.irp.f | 6 +- 20 files changed, 683 insertions(+), 75 deletions(-) create mode 100644 src/casscf/change_bitmasks.irp.f create mode 100644 src/casscf/cipsi_routines.irp.f create mode 100644 src/casscf/cisd_routine.irp.f create mode 100644 src/casscf/cisdtq_routine.irp.f create mode 100644 src/casscf/h_apply.irp.f create mode 100644 src/cisd/cisd_routine.irp.f create mode 100644 src/generators_fluid/NEED create mode 100644 src/generators_fluid/README.rst create mode 100644 src/generators_fluid/extract_cas.irp.f create mode 100644 src/generators_fluid/generators.irp.f create mode 100644 src/generators_fluid/generators_cas.irp.f create mode 100644 src/generators_fluid/generators_hf.irp.f create mode 100644 src/generators_fluid/generators_hf_sd.irp.f diff --git a/src/casscf/EZFIO.cfg b/src/casscf/EZFIO.cfg index d5526673..ce51a064 100644 --- a/src/casscf/EZFIO.cfg +++ b/src/casscf/EZFIO.cfg @@ -10,4 +10,10 @@ doc: Calculated |FCI| energy + |PT2| interface: ezfio size: (determinants.n_states) +[cisd_guess] +type: logical +doc: If true, the CASSCF starts with a CISD wave function +interface: ezfio,provider,ocaml +default: True + diff --git a/src/casscf/NEED b/src/casscf/NEED index c12b531e..b992ff71 100644 --- a/src/casscf/NEED +++ b/src/casscf/NEED @@ -1,4 +1,4 @@ cipsi selectors_full -generators_cas +generators_fluid two_body_rdm diff --git a/src/casscf/casscf.irp.f b/src/casscf/casscf.irp.f index 4270a9fb..c98bfc44 100644 --- a/src/casscf/casscf.irp.f +++ b/src/casscf/casscf.irp.f @@ -4,45 +4,86 @@ program casscf ! TODO : Put the documentation of the program here END_DOC no_vvvv_integrals = .True. - pt2_max = 0.02 - SOFT_TOUCH no_vvvv_integrals pt2_max - call run + SOFT_TOUCH no_vvvv_integrals + threshold_davidson = 1.d-7 + touch threshold_davidson + if(cisd_guess)then + logical :: converged + integer :: iteration + double precision :: energy + print*,'*******************************' + print*,'*******************************' + print*,'*******************************' + print*,'USING A CISD WAVE FUNCTION AS GUESS FOR THE MCSCF WF' + print*,'*******************************' + print*,'*******************************' + converged = .False. + iteration = 0 + generators_type = "HF" + touch generators_type + read_wf = .False. + touch read_wf + logical :: do_cisdtq + do_cisdtq = .True. + double precision :: thr + thr = 5.d-3 + do while (.not.converged) + call cisd_scf_iteration(converged,iteration,energy,thr) + if(HF_index.ne.1.and.iteration.gt.0)then + print*,'*******************************' + print*,'*******************************' + print*,'The HF determinant is not the dominant determinant in the CISD WF ...' + print*,'Therefore we skip the CISD WF ..' + print*,'*******************************' + print*,'*******************************' + do_cisdtq = .False. + exit + endif + if(iteration.gt.15.and..not.converged)then + print*,'It seems that the orbital optimization for the CISD WAVE FUNCTION CANNOT CONVERGE ...' + print*,'Passing to CISDTQ WAVE FUNCTION' + exit + endif + enddo + if(do_cisdtq)then + print*,'*******************************' + print*,'*******************************' + print*,'*******************************' + print*,'SWITCHING WITH A CISDTQ WAVE FUNCTION AS GUESS FOR THE MCSCF WF' + print*,'*******************************' + print*,'*******************************' + converged = .False. + iteration = 0 + read_wf = .False. + touch read_wf + pt2_max = 0.01d0 + touch pt2_max + energy = 0.d0 + do while (.not.converged) + call cisdtq_scf_iteration(converged,iteration,energy,thr) + if(HF_index.ne.1.and.iteration.gt.0)then + print*,'*******************************' + print*,'*******************************' + print*,'The HF determinant is not the dominant determinant in the CISDTQ WF ...' + print*,'Therefore we skip the CISDTQ WF ..' + print*,'*******************************' + print*,'*******************************' + exit + endif + if(iteration.gt.15.and..not.converged)then + print*,'It seems that the orbital optimization for the CISDTQ WAVE FUNCTION CANNOT CONVERGE ...' + print*,'Passing to CISDTQ WAVE FUNCTION' + exit + endif + enddo + endif + endif + generators_type = "CAS" + touch generators_type + read_wf = .False. + touch read_wf + pt2_max = 0.015d0 + touch pt2_max + call run_cipsi_scf end -subroutine run - implicit none - double precision :: energy_old, energy - logical :: converged - integer :: iteration - converged = .False. - - energy = 0.d0 - mo_label = "MCSCF" - iteration = 1 - do while (.not.converged) - call run_stochastic_cipsi - energy_old = energy - energy = eone+etwo+ecore - - call write_time(6) - call write_int(6,iteration,'CAS-SCF iteration') - call write_double(6,energy,'CAS-SCF energy') - call write_double(6,energy_improvement, 'Predicted energy improvement') - - converged = dabs(energy_improvement) < thresh_scf - pt2_max = dabs(energy_improvement / pt2_relative_error) - - mo_coef = NewOrbs - call save_mos - call map_deinit(mo_integrals_map) - iteration += 1 - N_det = N_det/2 - psi_det = psi_det_sorted - psi_coef = psi_coef_sorted - read_wf = .True. - FREE mo_integrals_map mo_two_e_integrals_in_map - SOFT_TOUCH mo_coef N_det pt2_max psi_det psi_coef - - enddo - -end diff --git a/src/casscf/change_bitmasks.irp.f b/src/casscf/change_bitmasks.irp.f new file mode 100644 index 00000000..cad6ec38 --- /dev/null +++ b/src/casscf/change_bitmasks.irp.f @@ -0,0 +1,14 @@ +subroutine only_act_bitmask + implicit none + integer :: i,j,k + do k = 1, N_generators_bitmask + do j = 1, 6 + do i = 1, N_int + generators_bitmask(i,1,j,k) = act_bitmask(i,1) + generators_bitmask(i,2,j,k) = act_bitmask(i,2) + enddo + enddo + enddo + touch generators_bitmask +end + diff --git a/src/casscf/cipsi_routines.irp.f b/src/casscf/cipsi_routines.irp.f new file mode 100644 index 00000000..58e95574 --- /dev/null +++ b/src/casscf/cipsi_routines.irp.f @@ -0,0 +1,72 @@ +subroutine run_cipsi_scf + implicit none + double precision :: energy_old, energy, extrap,extrap_old,pt2_max_begin + logical :: converged + integer :: iteration + print*,'*********************************' + print*,'*********************************' + print*,' DOING THE CIPSI-SCF ' + print*,'*********************************' + converged = .False. + pt2_max_begin = pt2_max + energy = 0.d0 + extrap = 0.d0 + mo_label = "MCSCF" + iteration = 1 + threshold_davidson = 1.d-09 + touch threshold_davidson + do while (.not.converged) + print*,'' + call write_int(6,iteration,'CI STEP OF THE ITERATION = ') + call write_double(6,pt2_max,'PT2 MAX = ') + call run_stochastic_cipsi + call change_orb_cipsi(converged,iteration,energy) + if(iteration.gt.n_it_scf_max.and..not.converged)then + print*,'It seems that the orbital optimization for the CISDTQ WAVE FUNCTION CANNOT CONVERGE ...' + print*,'The required delta E was :',thresh_scf + print*,'The obtained delta E was :',extrap - extrap_old + print*,'After ',iteration,'iterations ...' + print*,'Getting out of the SCF loop ...' + exit + endif + iteration += 1 + enddo + +end + +subroutine change_orb_cipsi(converged,iteration,energy) + implicit none + double precision :: energy_old, extrap,extrap_old,pt2_max_begin + double precision, intent(inout):: energy + logical, intent(out) :: converged + integer, intent(in) :: iteration + extrap_old = energy + energy = eone+etwo+ecore + extrap = extrapolated_energy(2,1) + + call write_time(6) + call write_int(6,iteration,'CAS-SCF iteration') + call write_double(6,energy,'CAS-SCF variational energy') + call write_double(6,extrap,'CAS-SCF extrapolated energy') + call write_double(6,extrap - extrap_old,'Change in extrapolated energy') + energy = extrap + call write_double(6,energy_improvement, 'Predicted energy improvement') + + converged = dabs(extrap - extrap_old) < thresh_scf + pt2_max = dabs(extrap - extrap_old) * 10.d0 + pt2_max = min(pt2_max,1.d-2) + pt2_max = max(pt2_max,1.d-10) + if(N_det.gt.10**6)then + pt2_max = max(pt2_max,1.d-2) + endif + + mo_coef = NewOrbs + call save_mos + call map_deinit(mo_integrals_map) + N_det = N_det/2 + psi_det = psi_det_sorted + psi_coef = psi_coef_sorted + read_wf = .True. + FREE mo_integrals_map mo_two_e_integrals_in_map + SOFT_TOUCH mo_coef N_det pt2_max psi_det psi_coef +end diff --git a/src/casscf/cisd_routine.irp.f b/src/casscf/cisd_routine.irp.f new file mode 100644 index 00000000..a8a30747 --- /dev/null +++ b/src/casscf/cisd_routine.irp.f @@ -0,0 +1,64 @@ +subroutine cisd_scf_iteration(converged,iteration,energy,thr) + implicit none + double precision, intent(in) :: thr + logical, intent(out) :: converged + integer, intent(inout) :: iteration + double precision, intent(out) :: energy + converged = .False. + call only_act_bitmask + call run_cisd + call change_orb_cisd(converged,iteration,energy,thr) +end + +subroutine change_orb_cisd(converged,iteration,energy,thr) + implicit none + double precision, intent(in) :: thr + logical, intent(inout) :: converged + integer, intent(inout) :: iteration + double precision, intent(inout) :: energy + double precision :: energy_old + energy_old = energy + + energy = eone+etwo+ecore + + call write_time(6) + call write_int(6,iteration,'CISD-SCF iteration') + call write_double(6,energy,'CISD-SCF energy') + call write_double(6,energy_improvement, 'Predicted energy improvement') + converged = dabs(energy_improvement) < thr + + mo_coef = NewOrbs + call save_mos + call map_deinit(mo_integrals_map) + FREE mo_integrals_map mo_two_e_integrals_in_map + iteration += 1 + +end + +subroutine run_cisd + implicit none + integer :: i + + if(pseudo_sym)then + call H_apply_cisd_sym + else + call H_apply_cisd + endif + print *, 'N_det = ', N_det + print*,'******************************' + print *, 'Energies of the states:' + do i = 1,N_states + print *, i, CI_energy(i) + enddo + if (N_states > 1) then + print*,'******************************' + print*,'Excitation energies ' + do i = 2, N_states + print*, i ,CI_energy(i) - CI_energy(1) + enddo + endif + psi_coef = ci_eigenvectors + SOFT_TOUCH psi_coef + call save_wavefunction + +end diff --git a/src/casscf/cisdtq_routine.irp.f b/src/casscf/cisdtq_routine.irp.f new file mode 100644 index 00000000..0479d462 --- /dev/null +++ b/src/casscf/cisdtq_routine.irp.f @@ -0,0 +1,47 @@ +subroutine cisdtq_scf_iteration(converged,iteration,energy,thr) + implicit none + double precision, intent(in) :: thr + logical, intent(out) :: converged + integer, intent(inout) :: iteration + double precision, intent(inout) :: energy + converged = .False. + call only_act_bitmask + generators_type = "HF_SD" + threshold_generators = 0.99d0 + touch threshold_generators + touch generators_type + selection_factor = 5 + touch selection_factor + call run_stochastic_cipsi + call change_orb_cisdtq(converged,iteration,energy,thr) +end + +subroutine change_orb_cisdtq(converged,iteration,energy,thr) + implicit none + double precision, intent(in) :: thr + logical, intent(inout) :: converged + integer, intent(inout) :: iteration + double precision, intent(inout) :: energy + double precision :: extrap,extrap_old,pt2_max_begin + extrap_old = energy + extrap = extrapolated_energy(2,1) + energy = extrap + + call write_time(6) + call write_int(6,iteration,'CISDTQ-SCF iteration') + call write_double(6,energy,'CISDTQ-SCF variational energy') + call write_double(6,extrap,'CISDTQ-SCF extrapolated energy') + call write_double(6,extrap - extrap_old,'Change in extrapolated energy') + + converged = dabs(extrap - extrap_old) < thr + pt2_max = dabs(extrap - extrap_old) * 10.d0 + pt2_max = max(pt2_max,1.d-10) + + mo_coef = NewOrbs + call save_mos + call map_deinit(mo_integrals_map) + FREE mo_integrals_map mo_two_e_integrals_in_map + iteration += 1 + +end + diff --git a/src/casscf/gradient.irp.f b/src/casscf/gradient.irp.f index 883a4665..b3c8988f 100644 --- a/src/casscf/gradient.irp.f +++ b/src/casscf/gradient.irp.f @@ -171,11 +171,11 @@ BEGIN_PROVIDER [real*8, gradvec2, (nMonoEx)] norm_grad+=gradvec2(indx)*gradvec2(indx) end do norm_grad=sqrt(norm_grad) - if (bavard) then +! if (bavard) then write(6,*) write(6,*) ' Norm of the orbital gradient (via D, P and integrals): ', norm_grad write(6,*) - endif +! endif END_PROVIDER diff --git a/src/casscf/h_apply.irp.f b/src/casscf/h_apply.irp.f new file mode 100644 index 00000000..6fcb2900 --- /dev/null +++ b/src/casscf/h_apply.irp.f @@ -0,0 +1,18 @@ +! Generates subroutine H_apply_cisd +! ---------------------------------- + +BEGIN_SHELL [ /usr/bin/env python2 ] +from generate_h_apply import H_apply +H = H_apply("cisd",do_double_exc=True) +print H + +from generate_h_apply import H_apply +H = H_apply("cisdtq",do_double_exc=True) +H.set_selection_pt2("epstein_nesbet_2x2") +print H + +H = H_apply("cisd_sym",do_double_exc=True) +H.filter_only_connected_to_hf() +print H +END_SHELL + diff --git a/src/casscf/neworbs.irp.f b/src/casscf/neworbs.irp.f index f4319485..16680452 100644 --- a/src/casscf/neworbs.irp.f +++ b/src/casscf/neworbs.irp.f @@ -66,6 +66,7 @@ END_PROVIDER integer :: best_vector real*8 :: best_overlap best_overlap=0.D0 + best_vector = -1000 do i=1,nMonoEx+1 if (SXeigenval(i).lt.0.D0) then if (abs(SXeigenvec(1,i)).gt.best_overlap) then @@ -74,7 +75,9 @@ END_PROVIDER end if end if end do - + if(best_vector.lt.0)then + best_vector = minloc(SXeigenval,nMonoEx+1) + endif energy_improvement = SXeigenval(best_vector) c0=SXeigenvec(1,best_vector) diff --git a/src/cisd/cisd.irp.f b/src/cisd/cisd.irp.f index 65f943d3..aaa29f59 100644 --- a/src/cisd/cisd.irp.f +++ b/src/cisd/cisd.irp.f @@ -46,34 +46,6 @@ program cisd END_DOC read_wf = .False. SOFT_TOUCH read_wf - call run -end - -subroutine run - implicit none - integer :: i - - if(pseudo_sym)then - call H_apply_cisd_sym - else - call H_apply_cisd - endif - print *, 'N_det = ', N_det - print*,'******************************' - print *, 'Energies of the states:' - do i = 1,N_states - print *, i, CI_energy(i) - enddo - if (N_states > 1) then - print*,'******************************' - print*,'Excitation energies ' - do i = 2, N_states - print*, i ,CI_energy(i) - CI_energy(1) - enddo - endif - psi_coef = ci_eigenvectors - SOFT_TOUCH psi_coef - call save_wavefunction - call ezfio_set_cisd_energy(CI_energy) - + call only_act_bitmask + call run_cisd end diff --git a/src/cisd/cisd_routine.irp.f b/src/cisd/cisd_routine.irp.f new file mode 100644 index 00000000..f9e477b1 --- /dev/null +++ b/src/cisd/cisd_routine.irp.f @@ -0,0 +1,42 @@ +subroutine only_act_bitmask + implicit none + integer :: i,j,k + do k = 1, N_generators_bitmask + do j = 1, 6 + do i = 1, N_int + generators_bitmask(i,1,j,k) = act_bitmask(i,1) + generators_bitmask(i,2,j,k) = act_bitmask(i,2) + enddo + enddo + enddo + touch generators_bitmask +end + +subroutine run_cisd + implicit none + integer :: i + + if(pseudo_sym)then + call H_apply_cisd_sym + else + call H_apply_cisd + endif + print *, 'N_det = ', N_det + print*,'******************************' + print *, 'Energies of the states:' + do i = 1,N_states + print *, i, CI_energy(i) + enddo + if (N_states > 1) then + print*,'******************************' + print*,'Excitation energies ' + do i = 2, N_states + print*, i ,CI_energy(i) - CI_energy(1) + enddo + endif + psi_coef = ci_eigenvectors + SOFT_TOUCH psi_coef + call save_wavefunction + call ezfio_set_cisd_energy(CI_energy) + +end diff --git a/src/generators_fluid/NEED b/src/generators_fluid/NEED new file mode 100644 index 00000000..d3d4d2c7 --- /dev/null +++ b/src/generators_fluid/NEED @@ -0,0 +1 @@ +determinants diff --git a/src/generators_fluid/README.rst b/src/generators_fluid/README.rst new file mode 100644 index 00000000..e69de29b diff --git a/src/generators_fluid/extract_cas.irp.f b/src/generators_fluid/extract_cas.irp.f new file mode 100644 index 00000000..9cdaf27f --- /dev/null +++ b/src/generators_fluid/extract_cas.irp.f @@ -0,0 +1,23 @@ +subroutine extract_cas + implicit none + BEGIN_DOC + ! Replaces the total wave function by the normalized projection on the CAS. + END_DOC + + integer :: i,j,k + do k=1,N_states + do j=1,N_det_generators + psi_coef(j,k) = psi_coef_generators(j,k) + enddo + enddo + + do j=1,N_det_generators + do k=1,N_int + psi_det(k,1,j) = psi_det_generators(k,1,j) + psi_det(k,2,j) = psi_det_generators(k,2,j) + enddo + enddo + N_det = N_det_generators + + SOFT_TOUCH N_det psi_det psi_coef +end diff --git a/src/generators_fluid/generators.irp.f b/src/generators_fluid/generators.irp.f new file mode 100644 index 00000000..153ab605 --- /dev/null +++ b/src/generators_fluid/generators.irp.f @@ -0,0 +1,101 @@ +use bitmasks + +BEGIN_PROVIDER [ character*(32), generators_type] + implicit none + generators_type = trim("CAS") + +END_PROVIDER + +BEGIN_PROVIDER [ integer, N_det_generators ] + implicit none + BEGIN_DOC + ! Number of generator detetrminants + END_DOC + if(generators_type == "CAS")then + N_det_generators = N_det_generators_CAS + else if (generators_type == "HF")then + N_det_generators = N_det_generators_HF + else if (generators_type == "HF_SD")then + N_det_generators = N_det_generators_HF_SD + endif + N_det_generators = max(N_det_generators,1) + call write_int(6,N_det_generators,'Number of generators') +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_generators, (psi_det_size,N_states) ] + implicit none + BEGIN_DOC + ! For Single reference wave functions, the generator is the + ! Hartree-Fock determinant + END_DOC + + if(generators_type == "CAS")then + psi_det_generators(1:N_int,1:2,1:N_det_generators_CAS) = psi_det_generators_CAS(1:N_int,1:2,1:N_det_generators_CAS) + psi_coef_generators(1:N_det_generators_CAS,1:N_states) = psi_coef_generators_CAS(1:N_det_generators_CAS,1:N_states) + else if (generators_type == "HF")then + psi_det_generators(1:N_int,1:2,1:N_det_generators_HF) = psi_det_generators_HF(1:N_int,1:2,1:N_det_generators_HF) + psi_coef_generators(1:N_det_generators_HF,1:N_states) = psi_coef_generators_HF(1:N_det_generators_HF,1:N_states) + else if (generators_type == "HF_SD")then + psi_det_generators(1:N_int,1:2,1:N_det_generators_HF_SD) = psi_det_generators_HF_SD(1:N_int,1:2,1:N_det_generators_HF_SD) + psi_coef_generators(1:N_det_generators_HF_SD,1:N_states) = psi_coef_generators_HF_SD(1:N_det_generators_HF_SD,1:N_states) + endif + +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_gen, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_sorted_gen, (psi_det_size,N_states) ] +&BEGIN_PROVIDER [ integer, psi_det_sorted_gen_order, (psi_det_size) ] + + implicit none + BEGIN_DOC + ! For Single reference wave functions, the generator is the + ! Hartree-Fock determinant + END_DOC + if(generators_type == "CAS")then + psi_det_sorted_gen = psi_det_sorted_gen_CAS + psi_coef_sorted_gen = psi_coef_sorted_gen_CAS + psi_det_sorted_gen_order = psi_det_sorted_gen_CAS_order + else if(generators_type == "HF")then + psi_det_sorted_gen = 0_bit_kind + psi_coef_sorted_gen = 0.d0 + psi_det_sorted_gen_order = 0 + else if(generators_type == "HF_SD")then + psi_det_sorted_gen = psi_det_sorted_gen_HF_SD + psi_coef_sorted_gen = psi_coef_sorted_gen_HF_SD + psi_det_sorted_gen_order = psi_det_sorted_gen_HF_SD_order + endif +END_PROVIDER + + +BEGIN_PROVIDER [integer, degree_max_generators] + implicit none + BEGIN_DOC +! Max degree of excitation (respect to HF) of the generators + END_DOC + integer :: i,degree + degree_max_generators = 0 + do i = 1, N_det_generators + call get_excitation_degree(HF_bitmask,psi_det_generators(1,1,i),degree,N_int) + if(degree .gt. degree_max_generators)then + degree_max_generators = degree + endif + enddo +END_PROVIDER + +BEGIN_PROVIDER [ integer, size_select_max] + implicit none + BEGIN_DOC + ! Size of the select_max array + END_DOC + size_select_max = 10000 +END_PROVIDER + +BEGIN_PROVIDER [ double precision, select_max, (size_select_max) ] + implicit none + BEGIN_DOC + ! Memo to skip useless selectors + END_DOC + select_max = huge(1.d0) +END_PROVIDER + diff --git a/src/generators_fluid/generators_cas.irp.f b/src/generators_fluid/generators_cas.irp.f new file mode 100644 index 00000000..b6d83e0a --- /dev/null +++ b/src/generators_fluid/generators_cas.irp.f @@ -0,0 +1,69 @@ +use bitmasks + +BEGIN_PROVIDER [ integer, N_det_generators_CAS ] + implicit none + BEGIN_DOC + ! Number of generator detetrminants + END_DOC + integer :: i,k,l + logical :: good + integer, external :: number_of_holes,number_of_particles + call write_time(6) + N_det_generators_CAS = 0 + do i=1,N_det + good = ( number_of_holes(psi_det_sorted(1,1,i)) ==0).and.(number_of_particles(psi_det_sorted(1,1,i))==0 ) + if (good) then + N_det_generators_CAS += 1 + endif + enddo + N_det_generators_CAS = max(N_det_generators_CAS,1) + call write_int(6,N_det_generators_CAS,'Number of generators_CAS') +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators_CAS, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_generators_CAS, (psi_det_size,N_states) ] +&BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_gen_CAS, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_sorted_gen_CAS, (psi_det_size,N_states) ] +&BEGIN_PROVIDER [ integer, psi_det_sorted_gen_CAS_order, (psi_det_size) ] + implicit none + BEGIN_DOC + ! For Single reference wave functions, the gen_CASerator is the + ! Hartree-Fock determinant + END_DOC + integer :: i, k, l, m + logical :: good + integer, external :: number_of_holes,number_of_particles + integer, allocatable :: nongen_CAS(:) + integer :: inongen_CAS + + allocate(nongen_CAS(N_det)) + + inongen_CAS = 0 + m=0 + do i=1,N_det + good = ( number_of_holes(psi_det_sorted(1,1,i)) ==0).and.(number_of_particles(psi_det_sorted(1,1,i))==0 ) + if (good) then + m = m+1 + psi_det_sorted_gen_CAS_order(i) = m + do k=1,N_int + psi_det_generators_CAS(k,1,m) = psi_det_sorted(k,1,i) + psi_det_generators_CAS(k,2,m) = psi_det_sorted(k,2,i) + enddo + psi_coef_generators_CAS(m,:) = psi_coef_sorted(i,:) + else + inongen_CAS += 1 + nongen_CAS(inongen_CAS) = i + endif + enddo + ASSERT (m == N_det_generators_CAS) + + psi_det_sorted_gen_CAS(:,:,:N_det_generators_CAS) = psi_det_generators_CAS(:,:,:N_det_generators_CAS) + psi_coef_sorted_gen_CAS(:N_det_generators_CAS, :) = psi_coef_generators_CAS(:N_det_generators_CAS, :) + do i=1,inongen_CAS + psi_det_sorted_gen_CAS_order(nongen_CAS(i)) = N_det_generators_CAS+i + psi_det_sorted_gen_CAS(:,:,N_det_generators_CAS+i) = psi_det_sorted(:,:,nongen_CAS(i)) + psi_coef_sorted_gen_CAS(N_det_generators_CAS+i, :) = psi_coef_sorted(nongen_CAS(i),:) + end do + +END_PROVIDER + diff --git a/src/generators_fluid/generators_hf.irp.f b/src/generators_fluid/generators_hf.irp.f new file mode 100644 index 00000000..29e2d365 --- /dev/null +++ b/src/generators_fluid/generators_hf.irp.f @@ -0,0 +1,51 @@ + +use bitmasks + +BEGIN_PROVIDER [ integer, N_det_generators_HF ] + implicit none + BEGIN_DOC + ! For Single reference wave functions, the number of generators is 1 : the + ! Hartree-Fock determinant + END_DOC + N_det_generators_HF = 1 +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators_HF, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_generators_HF, (psi_det_size,N_states) ] + implicit none + BEGIN_DOC + ! For Single reference wave functions, the generator is the + ! Hartree-Fock determinant + END_DOC + psi_det_generators_HF = 0_bit_kind + integer :: i,j + integer :: degree + + do i=1,N_int + psi_det_generators_HF(i,1,1) = HF_bitmask(i,1) + psi_det_generators_HF(i,2,1) = HF_bitmask(i,2) + enddo + + do j=1,N_det + call get_excitation_degree(HF_bitmask,psi_det(1,1,j),degree,N_int) + if (degree == 0) then + exit + endif + end do + + psi_det_generators_HF(:,:,1) = psi_det(:,:,j) + psi_coef_generators_HF(1,:) = psi_coef_generators_HF(j,:) + +END_PROVIDER + + BEGIN_PROVIDER [ integer , HF_index ] + implicit none + integer :: j,degree + do j=1,N_det + call get_excitation_degree(HF_bitmask,psi_det_sorted(1,1,j),degree,N_int) + if (degree == 0) then + HF_index = j + exit + endif + end do +END_PROVIDER diff --git a/src/generators_fluid/generators_hf_sd.irp.f b/src/generators_fluid/generators_hf_sd.irp.f new file mode 100644 index 00000000..9c13a5a0 --- /dev/null +++ b/src/generators_fluid/generators_hf_sd.irp.f @@ -0,0 +1,80 @@ + +use bitmasks + +BEGIN_PROVIDER [ integer, N_det_generators_HF_SD ] + implicit none + BEGIN_DOC + ! For Single reference wave functions, the number of generators is 1 : the + ! Hartree-Fock determinant + END_DOC + N_det_generators_HF_SD = 0 + integer :: i,degree + double precision :: thr + double precision :: accu + accu = 0.d0 + thr = threshold_generators + do i = 1, N_det + call get_excitation_degree(HF_bitmask,psi_det_sorted(1,1,i),degree,N_int) + if(degree.le.2.and. accu .le. thr )then + accu += psi_coef_sorted(i,1)**2 + N_det_generators_HF_SD += 1 + endif + enddo +!print*,'' +!print*,'N_det_generators_HF_SD = ',N_det_generators_HF_SD +END_PROVIDER + + BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators_HF_SD, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_generators_HF_SD, (psi_det_size,N_states) ] +&BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_gen_HF_SD, (N_int,2,psi_det_size) ] +&BEGIN_PROVIDER [ double precision, psi_coef_sorted_gen_HF_SD, (psi_det_size,N_states) ] +&BEGIN_PROVIDER [ integer, psi_det_sorted_gen_HF_SD_order, (psi_det_size) ] + implicit none + BEGIN_DOC + ! For Single reference wave functions, the generator is the + ! Hartree-Fock determinant + END_DOC + psi_det_generators_HF_SD = 0_bit_kind + integer :: i,j,k + integer :: degree + double precision :: thr + double precision :: accu + integer, allocatable :: nongen(:) + integer :: inongen + + allocate(nongen(N_det)) + + thr = threshold_generators + + accu = 0.d0 + k = 0 + inongen = 0 + do j=1,N_det + call get_excitation_degree(HF_bitmask,psi_det_sorted(1,1,j),degree,N_int) + if(degree.le.2.and. accu.le.thr )then + accu += psi_coef_sorted(j,1)**2 + k += 1 + psi_det_sorted_gen_HF_SD_order(j) = k + do i = 1, N_int + psi_det_generators_HF_SD(i,1,k) = psi_det_sorted(i,1,j) + psi_det_generators_HF_SD(i,2,k) = psi_det_sorted(i,2,j) + enddo + do i = 1, N_states + psi_coef_generators_HF_SD(k,i) = psi_coef_sorted(j,i) + enddo + else + inongen += 1 + nongen(inongen) = j + endif + end do + + psi_det_sorted_gen_HF_SD(:,:,:N_det_generators_HF_SD) = psi_det_generators_HF_SD(:,:,:N_det_generators_HF_SD) + psi_coef_sorted_gen_HF_SD(:N_det_generators_HF_SD, :) = psi_coef_generators_HF_SD(:N_det_generators_HF_SD, :) + do i=1,inongen + psi_det_sorted_gen_HF_SD_order(nongen(i)) = N_det_generators_HF_SD+i + psi_det_sorted_gen_HF_SD(:,:,N_det_generators_HF_SD+i) = psi_det_sorted(:,:,nongen(i)) + psi_coef_sorted_gen_HF_SD(N_det_generators_HF_SD+i, :) = psi_coef_sorted(nongen(i),:) + end do + +END_PROVIDER + diff --git a/src/two_body_rdm/orb_range_2_rdm.irp.f b/src/two_body_rdm/orb_range_2_rdm.irp.f index 8a47f73b..02df58d8 100644 --- a/src/two_body_rdm/orb_range_2_rdm.irp.f +++ b/src/two_body_rdm/orb_range_2_rdm.irp.f @@ -76,8 +76,12 @@ ispin = 4 state_av_act_two_rdm_spin_trace_mo = 0.d0 integer :: i - + double precision :: wall_0,wall_1 + call wall_time(wall_0) + print*,'providing the state average TWO-RDM ...' call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call wall_time(wall_1) + print*,'Time to provide the state average TWO-RDM',wall_1 - wall_0 END_PROVIDER From 919662ee0b64abb6a20a3e61c1d1bb261fcb05c4 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Thu, 4 Jul 2019 16:16:57 +0200 Subject: [PATCH 41/59] beginning to rewrite two_rdm --- src/casscf/get_energy.irp.f | 19 + src/davidson/u0_wee_u0.irp.f | 2 +- src/two_body_rdm/ab_only_routines.irp.f | 18 +- src/two_body_rdm/all_2rdm_routines.irp.f | 18 +- src/two_body_rdm/all_states_2_rdm.irp.f | 8 +- src/two_body_rdm/all_states_routines.irp.f | 20 +- src/two_body_rdm/orb_range_2_rdm.irp.f | 8 +- src/two_body_rdm/orb_range_2_rdm_openmp.irp.f | 87 +++ src/two_body_rdm/orb_range_routines.irp.f | 20 +- .../orb_range_routines_openmp.irp.f | 544 ++++++++++++++ ...utines_compute_2rdm_orb_range_openmp.irp.f | 683 ++++++++++++++++++ src/two_body_rdm/two_rdm.irp.f | 2 +- 12 files changed, 1381 insertions(+), 48 deletions(-) create mode 100644 src/two_body_rdm/orb_range_2_rdm_openmp.irp.f create mode 100644 src/two_body_rdm/orb_range_routines_openmp.irp.f create mode 100644 src/two_body_rdm/routines_compute_2rdm_orb_range_openmp.irp.f diff --git a/src/casscf/get_energy.irp.f b/src/casscf/get_energy.irp.f index 2a595fe7..384ff804 100644 --- a/src/casscf/get_energy.irp.f +++ b/src/casscf/get_energy.irp.f @@ -33,4 +33,23 @@ subroutine routine enddo enddo print*,'accu = ',accu(1) + + accu = 0.d0 + do ll = 1, n_act_orb + l = list_act(ll) + do kk = 1, n_act_orb + k = list_act(kk) + do jj = 1, n_act_orb + j = list_act(jj) + do ii = 1, n_act_orb + i = list_act(ii) + integral = get_two_e_integral(i,j,k,l,mo_integrals_map) + accu(1) += state_av_act_two_rdm_openmp_spin_trace_mo(ii,jj,kk,ll) * integral + enddo + enddo + enddo + enddo + print*,'accu = ',accu(1) + print*,'psi_energy_two_e = ',psi_energy_two_e + end diff --git a/src/davidson/u0_wee_u0.irp.f b/src/davidson/u0_wee_u0.irp.f index c1f163d4..0c543aca 100644 --- a/src/davidson/u0_wee_u0.irp.f +++ b/src/davidson/u0_wee_u0.irp.f @@ -6,7 +6,7 @@ BEGIN_PROVIDER [ double precision, psi_energy_two_e, (N_states) ] integer :: i,j call u_0_H_u_0_two_e(psi_energy_two_e,psi_coef,N_det,psi_det,N_int,N_states,psi_det_size) do i=N_det+1,N_states - psi_energy(i) = 0.d0 + psi_energy_two_e(i) = 0.d0 enddo END_PROVIDER diff --git a/src/two_body_rdm/ab_only_routines.irp.f b/src/two_body_rdm/ab_only_routines.irp.f index 9041c753..fb3c421c 100644 --- a/src/two_body_rdm/ab_only_routines.irp.f +++ b/src/two_body_rdm/ab_only_routines.irp.f @@ -1,5 +1,5 @@ - subroutine two_rdm_ab_nstates_openmp(big_array,dim1,dim2,dim3,dim4,u_0,N_st,sze) + subroutine two_rdm_ab_nstates(big_array,dim1,dim2,dim3,dim4,u_0,N_st,sze) use bitmasks implicit none BEGIN_DOC @@ -27,7 +27,7 @@ size(u_t, 1), & N_det, N_st) - call two_rdm_ab_nstates_openmp_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1) + call two_rdm_ab_nstates_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1) deallocate(u_t) do k=1,N_st @@ -37,7 +37,7 @@ end - subroutine two_rdm_ab_nstates_openmp_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + subroutine two_rdm_ab_nstates_work(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) use bitmasks implicit none BEGIN_DOC @@ -55,20 +55,20 @@ select case (N_int) case (1) - call two_rdm_ab_nstates_openmp_work_1(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + call two_rdm_ab_nstates_work_1(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) case (2) - call two_rdm_ab_nstates_openmp_work_2(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + call two_rdm_ab_nstates_work_2(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) case (3) - call two_rdm_ab_nstates_openmp_work_3(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + call two_rdm_ab_nstates_work_3(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) case (4) - call two_rdm_ab_nstates_openmp_work_4(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + call two_rdm_ab_nstates_work_4(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) case default - call two_rdm_ab_nstates_openmp_work_N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + call two_rdm_ab_nstates_work_N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) end select end BEGIN_TEMPLATE - subroutine two_rdm_ab_nstates_openmp_work_$N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + subroutine two_rdm_ab_nstates_work_$N_int(big_array,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) use bitmasks implicit none integer, intent(in) :: N_st,sze,istart,iend,ishift,istep diff --git a/src/two_body_rdm/all_2rdm_routines.irp.f b/src/two_body_rdm/all_2rdm_routines.irp.f index 3f08b18f..5127e31f 100644 --- a/src/two_body_rdm/all_2rdm_routines.irp.f +++ b/src/two_body_rdm/all_2rdm_routines.irp.f @@ -1,4 +1,4 @@ -subroutine all_two_rdm_dm_nstates_openmp(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_0,N_st,sze) +subroutine all_two_rdm_dm_nstates(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_0,N_st,sze) use bitmasks implicit none BEGIN_DOC @@ -28,7 +28,7 @@ subroutine all_two_rdm_dm_nstates_openmp(big_array_aa,big_array_bb,big_array_ab, size(u_t, 1), & N_det, N_st) - call all_two_rdm_dm_nstates_openmp_work(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1) + call all_two_rdm_dm_nstates_work(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,1,N_det,0,1) deallocate(u_t) do k=1,N_st @@ -38,7 +38,7 @@ subroutine all_two_rdm_dm_nstates_openmp(big_array_aa,big_array_bb,big_array_ab, end -subroutine all_two_rdm_dm_nstates_openmp_work(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) +subroutine all_two_rdm_dm_nstates_work(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) use bitmasks implicit none BEGIN_DOC @@ -58,21 +58,21 @@ subroutine all_two_rdm_dm_nstates_openmp_work(big_array_aa,big_array_bb,big_arra select case (N_int) case (1) - call all_two_rdm_dm_nstates_openmp_work_1(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + call all_two_rdm_dm_nstates_work_1(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) case (2) - call all_two_rdm_dm_nstates_openmp_work_2(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + call all_two_rdm_dm_nstates_work_2(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) case (3) - call all_two_rdm_dm_nstates_openmp_work_3(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + call all_two_rdm_dm_nstates_work_3(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) case (4) - call all_two_rdm_dm_nstates_openmp_work_4(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + call all_two_rdm_dm_nstates_work_4(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) case default - call all_two_rdm_dm_nstates_openmp_work_N_int(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) + call all_two_rdm_dm_nstates_work_N_int(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) end select end BEGIN_TEMPLATE -subroutine all_two_rdm_dm_nstates_openmp_work_$N_int(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) +subroutine all_two_rdm_dm_nstates_work_$N_int(big_array_aa,big_array_bb,big_array_ab,dim1,dim2,dim3,dim4,u_t,N_st,sze,istart,iend,ishift,istep) use bitmasks implicit none BEGIN_DOC diff --git a/src/two_body_rdm/all_states_2_rdm.irp.f b/src/two_body_rdm/all_states_2_rdm.irp.f index cd74758f..bc503223 100644 --- a/src/two_body_rdm/all_states_2_rdm.irp.f +++ b/src/two_body_rdm/all_states_2_rdm.irp.f @@ -14,7 +14,7 @@ ! condition for alpha/beta spin ispin = 1 all_states_act_two_rdm_alpha_alpha_mo = 0.D0 - call orb_range_all_states_two_rdm_openmp(all_states_act_two_rdm_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call orb_range_all_states_two_rdm(all_states_act_two_rdm_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) END_PROVIDER @@ -31,7 +31,7 @@ ! condition for alpha/beta spin ispin = 2 all_states_act_two_rdm_beta_beta_mo = 0.d0 - call orb_range_all_states_two_rdm_openmp(all_states_act_two_rdm_beta_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call orb_range_all_states_two_rdm(all_states_act_two_rdm_beta_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) END_PROVIDER @@ -53,7 +53,7 @@ ispin = 3 print*,'ispin = ',ispin all_states_act_two_rdm_alpha_beta_mo = 0.d0 - call orb_range_all_states_two_rdm_openmp(all_states_act_two_rdm_alpha_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call orb_range_all_states_two_rdm(all_states_act_two_rdm_alpha_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) END_PROVIDER @@ -77,7 +77,7 @@ all_states_act_two_rdm_spin_trace_mo = 0.d0 integer :: i - call orb_range_all_states_two_rdm_openmp(all_states_act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call orb_range_all_states_two_rdm(all_states_act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) END_PROVIDER diff --git a/src/two_body_rdm/all_states_routines.irp.f b/src/two_body_rdm/all_states_routines.irp.f index 3084dd5b..af7cafc2 100644 --- a/src/two_body_rdm/all_states_routines.irp.f +++ b/src/two_body_rdm/all_states_routines.irp.f @@ -1,4 +1,4 @@ -subroutine orb_range_all_states_two_rdm_openmp(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_0,N_st,sze) +subroutine orb_range_all_states_two_rdm(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_0,N_st,sze) use bitmasks implicit none BEGIN_DOC @@ -31,7 +31,7 @@ subroutine orb_range_all_states_two_rdm_openmp(big_array,dim1,norb,list_orb,list size(u_t, 1), & N_det, N_st) - call orb_range_all_states_two_rdm_openmp_work(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,1,N_det,0,1) + call orb_range_all_states_two_rdm_work(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,1,N_det,0,1) deallocate(u_t) do k=1,N_st @@ -40,7 +40,7 @@ subroutine orb_range_all_states_two_rdm_openmp(big_array,dim1,norb,list_orb,list end -subroutine orb_range_all_states_two_rdm_openmp_work(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) +subroutine orb_range_all_states_two_rdm_work(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) use bitmasks implicit none BEGIN_DOC @@ -60,15 +60,15 @@ subroutine orb_range_all_states_two_rdm_openmp_work(big_array,dim1,norb,list_orb select case (N_int) case (1) - call orb_range_all_states_two_rdm_openmp_work_1(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_all_states_two_rdm_work_1(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) case (2) - call orb_range_all_states_two_rdm_openmp_work_2(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_all_states_two_rdm_work_2(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) case (3) - call orb_range_all_states_two_rdm_openmp_work_3(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_all_states_two_rdm_work_3(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) case (4) - call orb_range_all_states_two_rdm_openmp_work_4(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_all_states_two_rdm_work_4(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) case default - call orb_range_all_states_two_rdm_openmp_work_N_int(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_all_states_two_rdm_work_N_int(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) end select end @@ -76,7 +76,7 @@ end BEGIN_TEMPLATE -subroutine orb_range_all_states_two_rdm_openmp_work_$N_int(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) +subroutine orb_range_all_states_two_rdm_work_$N_int(big_array,dim1,norb,list_orb,list_orb_reverse,ispin,u_t,N_st,sze,istart,iend,ishift,istep) use bitmasks implicit none BEGIN_DOC @@ -129,7 +129,7 @@ subroutine orb_range_all_states_two_rdm_openmp_work_$N_int(big_array,dim1,norb,l else if(ispin == 4)then spin_trace = .True. else - print*,'Wrong parameter for ispin in general_two_rdm_dm_nstates_openmp_work' + print*,'Wrong parameter for ispin in general_two_rdm_dm_nstates_work' print*,'ispin = ',ispin stop endif diff --git a/src/two_body_rdm/orb_range_2_rdm.irp.f b/src/two_body_rdm/orb_range_2_rdm.irp.f index 02df58d8..d441e1df 100644 --- a/src/two_body_rdm/orb_range_2_rdm.irp.f +++ b/src/two_body_rdm/orb_range_2_rdm.irp.f @@ -14,7 +14,7 @@ ! condition for alpha/beta spin ispin = 1 state_av_act_two_rdm_alpha_alpha_mo = 0.D0 - call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call orb_range_two_rdm_state_av(state_av_act_two_rdm_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) END_PROVIDER @@ -31,7 +31,7 @@ ! condition for alpha/beta spin ispin = 2 state_av_act_two_rdm_beta_beta_mo = 0.d0 - call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_beta_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call orb_range_two_rdm_state_av(state_av_act_two_rdm_beta_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) END_PROVIDER @@ -53,7 +53,7 @@ ispin = 3 print*,'ispin = ',ispin state_av_act_two_rdm_alpha_beta_mo = 0.d0 - call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_alpha_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call orb_range_two_rdm_state_av(state_av_act_two_rdm_alpha_beta_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) END_PROVIDER @@ -79,7 +79,7 @@ double precision :: wall_0,wall_1 call wall_time(wall_0) print*,'providing the state average TWO-RDM ...' - call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call orb_range_two_rdm_state_av(state_av_act_two_rdm_spin_trace_mo,n_act_orb,n_act_orb,list_act,list_act_reverse,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) call wall_time(wall_1) print*,'Time to provide the state average TWO-RDM',wall_1 - wall_0 diff --git a/src/two_body_rdm/orb_range_2_rdm_openmp.irp.f b/src/two_body_rdm/orb_range_2_rdm_openmp.irp.f new file mode 100644 index 00000000..70bf0201 --- /dev/null +++ b/src/two_body_rdm/orb_range_2_rdm_openmp.irp.f @@ -0,0 +1,87 @@ + + + + BEGIN_PROVIDER [double precision, state_av_act_two_rdm_openmp_alpha_alpha_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + implicit none + double precision, allocatable :: state_weights(:) + BEGIN_DOC +! state_av_act_two_rdm_openmp_alpha_alpha_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-alpha electron pairs +! = + END_DOC + allocate(state_weights(N_states)) + state_weights = 1.d0/dble(N_states) + integer :: ispin + ! condition for alpha/beta spin + ispin = 1 + state_av_act_two_rdm_openmp_alpha_alpha_mo = 0.D0 + call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_openmp_alpha_alpha_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + + END_PROVIDER + + BEGIN_PROVIDER [double precision, state_av_act_two_rdm_openmp_beta_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + implicit none + double precision, allocatable :: state_weights(:) + BEGIN_DOC +! state_av_act_two_rdm_openmp_beta_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for beta-beta electron pairs +! = + END_DOC + allocate(state_weights(N_states)) + state_weights = 1.d0/dble(N_states) + integer :: ispin + ! condition for alpha/beta spin + ispin = 2 + state_av_act_two_rdm_openmp_beta_beta_mo = 0.d0 + call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_openmp_beta_beta_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + + END_PROVIDER + + BEGIN_PROVIDER [double precision, state_av_act_two_rdm_openmp_alpha_beta_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + implicit none + double precision, allocatable :: state_weights(:) + BEGIN_DOC +! state_av_act_two_rdm_openmp_alpha_beta_mo(i,j,k,l) = state average physicist two-body rdm restricted to the ACTIVE indices for alpha-beta electron pairs +! = + END_DOC + allocate(state_weights(N_states)) + state_weights = 1.d0/dble(N_states) + integer :: ispin + ! condition for alpha/beta spin + print*,'' + print*,'' + print*,'' + print*,'providint state_av_act_two_rdm_openmp_alpha_beta_mo ' + ispin = 3 + print*,'ispin = ',ispin + state_av_act_two_rdm_openmp_alpha_beta_mo = 0.d0 + call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_openmp_alpha_beta_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + + END_PROVIDER + + + BEGIN_PROVIDER [double precision, state_av_act_two_rdm_openmp_spin_trace_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] + implicit none + BEGIN_DOC +! state_av_act_two_rdm_openmp_spin_trace_mo(i,j,k,l) = state average physicist spin trace two-body rdm restricted to the ACTIVE indices +! The active part of the two-electron energy can be computed as: +! +! \sum_{i,j,k,l = 1, n_act_orb} state_av_act_two_rdm_openmp_spin_trace_mo(i,j,k,l) * < ii jj | kk ll > +! +! with ii = list_act(i), jj = list_act(j), kk = list_act(k), ll = list_act(l) + END_DOC + double precision, allocatable :: state_weights(:) + allocate(state_weights(N_states)) + state_weights = 1.d0/dble(N_states) + integer :: ispin + ! condition for alpha/beta spin + ispin = 4 + state_av_act_two_rdm_openmp_spin_trace_mo = 0.d0 + integer :: i + double precision :: wall_0,wall_1 + call wall_time(wall_0) + print*,'providing the state average TWO-RDM ...' + call orb_range_two_rdm_state_av_openmp(state_av_act_two_rdm_openmp_spin_trace_mo,n_act_orb,n_act_orb,list_act,state_weights,ispin,psi_coef,size(psi_coef,2),size(psi_coef,1)) + + call wall_time(wall_1) + print*,'Time to provide the state average TWO-RDM',wall_1 - wall_0 + END_PROVIDER + diff --git a/src/two_body_rdm/orb_range_routines.irp.f b/src/two_body_rdm/orb_range_routines.irp.f index b82c4799..d5bd7d1c 100644 --- a/src/two_body_rdm/orb_range_routines.irp.f +++ b/src/two_body_rdm/orb_range_routines.irp.f @@ -1,4 +1,4 @@ -subroutine orb_range_two_rdm_state_av_openmp(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_0,N_st,sze) +subroutine orb_range_two_rdm_state_av(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_0,N_st,sze) use bitmasks implicit none BEGIN_DOC @@ -31,7 +31,7 @@ subroutine orb_range_two_rdm_state_av_openmp(big_array,dim1,norb,list_orb,list_o size(u_t, 1), & N_det, N_st) - call orb_range_two_rdm_state_av_openmp_work(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,1,N_det,0,1) + call orb_range_two_rdm_state_av_work(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,1,N_det,0,1) deallocate(u_t) do k=1,N_st @@ -40,7 +40,7 @@ subroutine orb_range_two_rdm_state_av_openmp(big_array,dim1,norb,list_orb,list_o end -subroutine orb_range_two_rdm_state_av_openmp_work(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) +subroutine orb_range_two_rdm_state_av_work(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) use bitmasks implicit none BEGIN_DOC @@ -60,15 +60,15 @@ subroutine orb_range_two_rdm_state_av_openmp_work(big_array,dim1,norb,list_orb,l select case (N_int) case (1) - call orb_range_two_rdm_state_av_openmp_work_1(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_two_rdm_state_av_work_1(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) case (2) - call orb_range_two_rdm_state_av_openmp_work_2(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_two_rdm_state_av_work_2(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) case (3) - call orb_range_two_rdm_state_av_openmp_work_3(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_two_rdm_state_av_work_3(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) case (4) - call orb_range_two_rdm_state_av_openmp_work_4(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_two_rdm_state_av_work_4(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) case default - call orb_range_two_rdm_state_av_openmp_work_N_int(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + call orb_range_two_rdm_state_av_work_N_int(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) end select end @@ -76,7 +76,7 @@ end BEGIN_TEMPLATE -subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) +subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) use bitmasks implicit none BEGIN_DOC @@ -130,7 +130,7 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis else if(ispin == 4)then spin_trace = .True. else - print*,'Wrong parameter for ispin in general_two_rdm_state_av_openmp_work' + print*,'Wrong parameter for ispin in general_two_rdm_state_av_work' print*,'ispin = ',ispin stop endif diff --git a/src/two_body_rdm/orb_range_routines_openmp.irp.f b/src/two_body_rdm/orb_range_routines_openmp.irp.f new file mode 100644 index 00000000..7d791f7c --- /dev/null +++ b/src/two_body_rdm/orb_range_routines_openmp.irp.f @@ -0,0 +1,544 @@ +subroutine orb_range_two_rdm_state_av_openmp(big_array,dim1,norb,list_orb,state_weights,ispin,u_0,N_st,sze) + use bitmasks + implicit none + BEGIN_DOC + ! if ispin == 1 :: alpha/alpha 2rdm + ! == 2 :: beta /beta 2rdm + ! == 3 :: alpha/beta 2rdm + ! == 4 :: spin traced 2rdm :: aa + bb + 0.5 (ab + ba)) + ! + ! Assumes that the determinants are in psi_det + ! + ! istart, iend, ishift, istep are used in ZMQ parallelization. + END_DOC + integer, intent(in) :: N_st,sze + integer, intent(in) :: dim1,norb,list_orb(norb),ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + double precision, intent(in) :: u_0(sze,N_st),state_weights(N_st) + + integer :: k + double precision, allocatable :: u_t(:,:) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t + allocate(u_t(N_st,N_det)) + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order,N_det) + enddo + call dtranspose( & + u_0, & + size(u_0, 1), & + u_t, & + size(u_t, 1), & + N_det, N_st) + + call orb_range_two_rdm_state_av_openmp_work(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,1,N_det,0,1) + deallocate(u_t) + + do k=1,N_st + call dset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det) + enddo + +end + +subroutine orb_range_two_rdm_state_av_openmp_work(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + BEGIN_DOC + ! Computes two-rdm + ! + ! Default should be 1,N_det,0,1 + END_DOC + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + integer, intent(in) :: dim1,norb,list_orb(norb),ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + double precision, intent(in) :: u_t(N_st,N_det),state_weights(N_st) + + integer :: k + + PROVIDE N_int + + select case (N_int) + case (1) + call orb_range_two_rdm_state_av_openmp_work_1(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + case (2) + call orb_range_two_rdm_state_av_openmp_work_2(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + case (3) + call orb_range_two_rdm_state_av_openmp_work_3(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + case (4) + call orb_range_two_rdm_state_av_openmp_work_4(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + case default + call orb_range_two_rdm_state_av_openmp_work_N_int(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + end select +end + + + + + BEGIN_TEMPLATE +subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) + use bitmasks + implicit none + BEGIN_DOC + ! Computes the two rdm for the N_st vectors |u_t> + ! if ispin == 1 :: alpha/alpha 2rdm + ! == 2 :: beta /beta 2rdm + ! == 3 :: alpha/beta 2rdm + ! == 4 :: spin traced 2rdm :: aa + bb + 0.5 (ab + ba)) + ! The 2rdm will be computed only on the list of orbitals list_orb, which contains norb + ! In any cases, the state average weights will be used with an array state_weights + ! Default should be 1,N_det,0,1 for istart,iend,ishift,istep + END_DOC + integer, intent(in) :: N_st,sze,istart,iend,ishift,istep + double precision, intent(in) :: u_t(N_st,N_det),state_weights(N_st) + integer, intent(in) :: dim1,norb,list_orb(norb),ispin + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + + integer :: i,j,k,l + integer :: k_a, k_b, l_a, l_b, m_a, m_b + integer :: istate + integer :: krow, kcol, krow_b, kcol_b + integer :: lrow, lcol + integer :: mrow, mcol + integer(bit_kind) :: spindet($N_int) + integer(bit_kind) :: tmp_det($N_int,2) + integer(bit_kind) :: tmp_det2($N_int,2) + integer(bit_kind) :: tmp_det3($N_int,2) + integer(bit_kind), allocatable :: buffer(:,:) + integer :: n_doubles + integer, allocatable :: doubles(:) + integer, allocatable :: singles_a(:) + integer, allocatable :: singles_b(:) + integer, allocatable :: idx(:), idx0(:) + integer :: maxab, n_singles_a, n_singles_b, kcol_prev + integer*8 :: k8 + double precision :: c_average + + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + integer(bit_kind) :: orb_bitmask($N_int) + integer :: list_orb_reverse(mo_num) + integer, allocatable :: keys(:,:) + double precision, allocatable :: values(:) + integer :: nkeys,sze_buff + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + else + print*,'Wrong parameter for ispin in general_two_rdm_state_av_openmp_work' + print*,'ispin = ',ispin + stop + endif + + !do i = 1, N_int + ! det_1_act(i,1) = iand(det_1(i,1),orb_bitmask(i)) + ! det_1_act(i,2) = iand(det_1(i,2),orb_bitmask(i)) + !enddo + + + PROVIDE N_int + + call list_to_bitstring( orb_bitmask, list_orb, norb, N_int) + sze_buff = norb ** 3 + list_orb_reverse = -1000 + do i = 1, norb + list_orb_reverse(list_orb(i)) = i + enddo + maxab = max(N_det_alpha_unique, N_det_beta_unique)+1 + allocate(idx0(maxab)) + + do i=1,maxab + idx0(i) = i + enddo + + ! Prepare the array of all alpha single excitations + ! ------------------------------------------------- + + PROVIDE N_int nthreads_davidson + !!$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) & + ! !$OMP SHARED(psi_bilinear_matrix_rows, N_det, & + ! !$OMP psi_bilinear_matrix_columns, & + ! !$OMP psi_det_alpha_unique, psi_det_beta_unique,& + ! !$OMP n_det_alpha_unique, n_det_beta_unique, N_int,& + ! !$OMP psi_bilinear_matrix_transp_rows, & + ! !$OMP psi_bilinear_matrix_transp_columns, & + ! !$OMP psi_bilinear_matrix_transp_order, N_st, & + ! !$OMP psi_bilinear_matrix_order_transp_reverse, & + ! !$OMP psi_bilinear_matrix_columns_loc, & + ! !$OMP psi_bilinear_matrix_transp_rows_loc, & + ! !$OMP istart, iend, istep, irp_here, v_t, s_t, & + ! !$OMP ishift, idx0, u_t, maxab) & + ! !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,& + ! !$OMP lcol, lrow, l_a, l_b, & + ! !$OMP buffer, doubles, n_doubles, & + ! !$OMP tmp_det2, idx, l, kcol_prev, & + ! !$OMP singles_a, n_singles_a, singles_b, & + ! !$OMP n_singles_b, k8) + + ! Alpha/Beta double excitations + ! ============================= + nkeys = 0 + allocate( keys(4,sze_buff), values(sze_buff)) + allocate( buffer($N_int,maxab), & + singles_a(maxab), & + singles_b(maxab), & + doubles(maxab), & + idx(maxab)) + + kcol_prev=-1 + + ASSERT (iend <= N_det) + ASSERT (istart > 0) + ASSERT (istep > 0) + + !!$OMP DO SCHEDULE(dynamic,64) + do k_a=istart+ishift,iend,istep + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + if (kcol /= kcol_prev) then + call get_all_spin_singles_$N_int( & + psi_det_beta_unique, idx0, & + tmp_det(1,2), N_det_beta_unique, & + singles_b, n_singles_b) + endif + kcol_prev = kcol + + ! Loop over singly excited beta columns + ! ------------------------------------- + + do i=1,n_singles_b + lcol = singles_b(i) + + tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol) + + l_a = psi_bilinear_matrix_columns_loc(lcol) + ASSERT (l_a <= N_det) + + do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - l_a + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + buffer(1:$N_int,j) = psi_det_alpha_unique(1:$N_int, lrow) + + ASSERT (l_a <= N_det) + idx(j) = l_a + l_a = l_a+1 + enddo + j = j-1 + + call get_all_spin_singles_$N_int( & + buffer, idx, tmp_det(1,1), j, & + singles_a, n_singles_a ) + + ! Loop over alpha singles + ! ----------------------- + + if(alpha_beta.or.spin_trace)then + do k = 1,n_singles_a + l_a = singles_a(k) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) + c_average = 0.d0 + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + c_average += c_1(l) * c_2(l) * state_weights(l) + enddo + if(alpha_beta)then + ! only ONE contribution + if (nkeys+1 .ge. size(values)) then + call update_keys_values(keys,values,size(values),nkeys,dim1,big_array) + nkeys = 0 + endif + else if (spin_trace)then + ! TWO contributions + if (nkeys+2 .ge. size(values)) then + call update_keys_values(keys,values,size(values),nkeys,dim1,big_array) + nkeys = 0 + endif + endif + call orb_range_off_diag_double_to_two_rdm_ab_dm_buffer(tmp_det,tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + + enddo + endif + + enddo + + enddo + ! !$OMP END DO + + ! !$OMP DO SCHEDULE(dynamic,64) + do k_a=istart+ishift,iend,istep + + + ! Single and double alpha exitations + ! =================================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + ! Initial determinant is at k_b in beta-major representation + ! ---------------------------------------------------------------------- + + k_b = psi_bilinear_matrix_order_transp_reverse(k_a) + ASSERT (k_b <= N_det) + + spindet(1:$N_int) = tmp_det(1:$N_int,1) + + ! Loop inside the beta column to gather all the connected alphas + lcol = psi_bilinear_matrix_columns(k_a) + l_a = psi_bilinear_matrix_columns_loc(lcol) + do i=1,N_det_alpha_unique + if (l_a > N_det) exit + lcol = psi_bilinear_matrix_columns(l_a) + if (lcol /= kcol) exit + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + buffer(1:$N_int,i) = psi_det_alpha_unique(1:$N_int, lrow) + idx(i) = l_a + l_a = l_a+1 + enddo + i = i-1 + + call get_all_spin_singles_and_doubles_$N_int( & + buffer, idx, spindet, i, & + singles_a, doubles, n_singles_a, n_doubles ) + + ! Compute Hij for all alpha singles + ! ---------------------------------- + + tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + do i=1,n_singles_a + l_a = singles_a(i) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, lrow) + c_average = 0.d0 + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + c_average += c_1(l) * c_2(l) * state_weights(l) + enddo + if(alpha_beta.or.spin_trace.or.alpha_alpha)then + ! increment the alpha/beta part for single excitations +!!!! call orb_range_off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + ! increment the alpha/alpha part for single excitations +!!!! call orb_range_off_diagonal_single_to_two_rdm_aa_dm(tmp_det,tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + endif + + enddo + + + ! Compute Hij for all alpha doubles + ! ---------------------------------- + + if(alpha_alpha.or.spin_trace)then + do i=1,n_doubles + l_a = doubles(i) + ASSERT (l_a <= N_det) + + lrow = psi_bilinear_matrix_rows(l_a) + ASSERT (lrow <= N_det_alpha_unique) + + c_average = 0.d0 + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + c_average += c_1(l) * c_2(l) * state_weights(l) + enddo +!!!! call orb_range_off_diagonal_double_to_two_rdm_aa_dm(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + enddo + endif + + + ! Single and double beta excitations + ! ================================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + kcol = psi_bilinear_matrix_columns(k_a) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + spindet(1:$N_int) = tmp_det(1:$N_int,2) + + ! Initial determinant is at k_b in beta-major representation + ! ----------------------------------------------------------------------- + + k_b = psi_bilinear_matrix_order_transp_reverse(k_a) + ASSERT (k_b <= N_det) + + ! Loop inside the alpha row to gather all the connected betas + lrow = psi_bilinear_matrix_transp_rows(k_b) + l_b = psi_bilinear_matrix_transp_rows_loc(lrow) + do i=1,N_det_beta_unique + if (l_b > N_det) exit + lrow = psi_bilinear_matrix_transp_rows(l_b) + if (lrow /= krow) exit + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + buffer(1:$N_int,i) = psi_det_beta_unique(1:$N_int, lcol) + idx(i) = l_b + l_b = l_b+1 + enddo + i = i-1 + + call get_all_spin_singles_and_doubles_$N_int( & + buffer, idx, spindet, i, & + singles_b, doubles, n_singles_b, n_doubles ) + + ! Compute Hij for all beta singles + ! ---------------------------------- + + tmp_det2(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + do i=1,n_singles_b + l_b = singles_b(i) + ASSERT (l_b <= N_det) + + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + tmp_det2(1:$N_int,2) = psi_det_beta_unique (1:$N_int, lcol) + l_a = psi_bilinear_matrix_transp_order(l_b) + c_average = 0.d0 + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + c_average += c_1(l) * c_2(l) * state_weights(l) + enddo + if(alpha_beta.or.spin_trace.or.beta_beta)then + ! increment the alpha/beta part for single excitations +!!!! call orb_range_off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + ! increment the beta /beta part for single excitations +!!!! call orb_range_off_diagonal_single_to_two_rdm_bb_dm(tmp_det, tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + endif + enddo + + ! Compute Hij for all beta doubles + ! ---------------------------------- + + if(beta_beta.or.spin_trace)then + do i=1,n_doubles + l_b = doubles(i) + ASSERT (l_b <= N_det) + + lcol = psi_bilinear_matrix_transp_columns(l_b) + ASSERT (lcol <= N_det_beta_unique) + + l_a = psi_bilinear_matrix_transp_order(l_b) + c_average = 0.d0 + do l= 1, N_states + c_1(l) = u_t(l,l_a) + c_2(l) = u_t(l,k_a) + c_average += c_1(l) * c_2(l) * state_weights(l) + enddo +!!!! call orb_range_off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_alpha_unique(1, lcol),c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + ASSERT (l_a <= N_det) + + enddo + endif + + + ! Diagonal contribution + ! ===================== + + + ! Initial determinant is at k_a in alpha-major representation + ! ----------------------------------------------------------------------- + + krow = psi_bilinear_matrix_rows(k_a) + ASSERT (krow <= N_det_alpha_unique) + + kcol = psi_bilinear_matrix_columns(k_a) + ASSERT (kcol <= N_det_beta_unique) + + tmp_det(1:$N_int,1) = psi_det_alpha_unique(1:$N_int, krow) + tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol) + + double precision, external :: diag_wee_mat_elem, diag_S_mat_elem + + double precision :: c_1(N_states),c_2(N_states) + c_average = 0.d0 + do l = 1, N_states + c_1(l) = u_t(l,k_a) + c_average += c_1(l) * c_1(l) * state_weights(l) + enddo + + call update_keys_values(keys,values,size(values),nkeys,dim1,big_array) + nkeys = 0 + call orb_range_diag_to_all_two_rdm_dm_buffer(tmp_det,c_average,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + call update_keys_values(keys,values,size(values),nkeys,dim1,big_array) + nkeys = 0 + + end do + !!$OMP END DO + deallocate(buffer, singles_a, singles_b, doubles, idx) + !!$OMP END PARALLEL + +end + + SUBST [ N_int ] + + 1;; + 2;; + 3;; + 4;; + N_int;; + + END_TEMPLATE + + +subroutine update_keys_values(keys,values,size_buff,nkeys,dim1,big_array) + implicit none + integer, intent(in) :: size_buff,nkeys,dim1 + integer, intent(in) :: keys(4,size_buff) + double precision, intent(in) :: values(size_buff) + double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + + integer :: i,h1,h2,p1,p2 + do i = 1, nkeys + h1 = keys(1,i) + h2 = keys(2,i) + p1 = keys(3,i) + p2 = keys(4,i) + big_array(h1,h2,p1,p2) += values(i) + enddo + +end diff --git a/src/two_body_rdm/routines_compute_2rdm_orb_range_openmp.irp.f b/src/two_body_rdm/routines_compute_2rdm_orb_range_openmp.irp.f new file mode 100644 index 00000000..ae1c3a54 --- /dev/null +++ b/src/two_body_rdm/routines_compute_2rdm_orb_range_openmp.irp.f @@ -0,0 +1,683 @@ + subroutine orb_range_diag_to_all_two_rdm_dm_buffer(det_1,c_1,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + use bitmasks + BEGIN_DOC + ! routine that update the DIAGONAL PART of the two body rdms in a specific range of orbitals for a given determinant det_1 + ! + ! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 + ! + ! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals + ! + ! ispin determines which spin-spin component of the two-rdm you will update + ! + ! ispin == 1 :: alpha/ alpha + ! ispin == 2 :: beta / beta + ! ispin == 3 :: alpha/ beta + ! ispin == 4 :: spin traced <=> total two-rdm + END_DOC + implicit none + integer, intent(in) :: ispin,sze_buff + integer, intent(in) :: list_orb_reverse(mo_num) + integer(bit_kind), intent(in) :: det_1(N_int,2) + integer(bit_kind), intent(in) :: orb_bitmask(N_int) + double precision, intent(in) :: c_1 + double precision, intent(out) :: values(sze_buff) + integer , intent(out) :: keys(4,sze_buff) + integer , intent(inout):: nkeys + + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate + integer(bit_kind) :: det_1_act(N_int,2) + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + do i = 1, N_int + det_1_act(i,1) = iand(det_1(i,1),orb_bitmask(i)) + det_1_act(i,2) = iand(det_1(i,2),orb_bitmask(i)) + enddo + + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + call bitstring_to_list_ab(det_1_act, occ, n_occ_ab, N_int) + logical :: is_integer_in_string + integer :: i1,i2 + if(alpha_beta)then + do i = 1, n_occ_ab(1) + i1 = occ(i,1) + do j = 1, n_occ_ab(2) + i2 = occ(j,2) + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + nkeys += 1 + values(nkeys) = c_1 + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h1 + keys(4,nkeys) = h2 + enddo + enddo + else if (alpha_alpha)then + do i = 1, n_occ_ab(1) + i1 = occ(i,1) + do j = 1, n_occ_ab(1) + i2 = occ(j,1) + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h1 + keys(4,nkeys) = h2 + nkeys += 1 + values(nkeys) = -0.5d0 * c_1 + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h2 + keys(4,nkeys) = h1 + enddo + enddo + else if (beta_beta)then + do i = 1, n_occ_ab(2) + i1 = occ(i,2) + do j = 1, n_occ_ab(2) + i2 = occ(j,2) + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h1 + keys(4,nkeys) = h2 + nkeys += 1 + values(nkeys) = -0.5d0 * c_1 + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h2 + keys(4,nkeys) = h1 + enddo + enddo + else if(spin_trace)then + ! 0.5 * (alpha beta + beta alpha) + do i = 1, n_occ_ab(1) + i1 = occ(i,1) + do j = 1, n_occ_ab(2) + i2 = occ(j,2) + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h1 + keys(4,nkeys) = h2 + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = h2 + keys(4,nkeys) = h1 + enddo + enddo + do i = 1, n_occ_ab(1) + i1 = occ(i,1) + do j = 1, n_occ_ab(1) + i2 = occ(j,1) + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h1 + keys(4,nkeys) = h2 + nkeys += 1 + values(nkeys) = -0.5d0 * c_1 + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h2 + keys(4,nkeys) = h1 + enddo + enddo + do i = 1, n_occ_ab(2) + i1 = occ(i,2) + do j = 1, n_occ_ab(2) + i2 = occ(j,2) + h1 = list_orb_reverse(i1) + h2 = list_orb_reverse(i2) + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h1 + keys(4,nkeys) = h2 + nkeys += 1 + values(nkeys) = -0.5d0 * c_1 + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h2 + keys(4,nkeys) = h1 + enddo + enddo + endif + end + + + subroutine orb_range_off_diag_double_to_two_rdm_ab_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + use bitmasks + BEGIN_DOC +! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for +! +! a given couple of determinant det_1, det_2 being a alpha/beta DOUBLE excitation with respect to one another +! +! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 +! +! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +! +! ispin determines which spin-spin component of the two-rdm you will update +! +! ispin == 1 :: alpha/ alpha +! ispin == 2 :: beta / beta +! ispin == 3 :: alpha/ beta +! ispin == 4 :: spin traced <=> total two-rdm +! +! here, only ispin == 3 or 4 will do something + END_DOC + implicit none + integer, intent(in) :: ispin,sze_buff + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(in) :: c_1 + double precision, intent(out) :: values(sze_buff) + integer , intent(out) :: keys(4,sze_buff) + integer , intent(inout):: nkeys + integer :: i,j,h1,h2,p1,p2,istate + integer :: exc(0:2,2,2) + double precision :: phase + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + call get_double_excitation(det_1,det_2,exc,phase,N_int) + h1 = exc(1,1,1) + if(list_orb_reverse(h1).lt.0)return + h1 = list_orb_reverse(h1) + h2 = exc(1,1,2) + if(list_orb_reverse(h2).lt.0)return + h2 = list_orb_reverse(h2) + p1 = exc(1,2,1) + if(list_orb_reverse(p1).lt.0)return + p1 = list_orb_reverse(p1) + p2 = exc(1,2,2) + if(list_orb_reverse(p2).lt.0)return + p2 = list_orb_reverse(p2) + if(alpha_beta)then + nkeys += 1 + values(nkeys) = c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + else if(spin_trace)then + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = p1 + keys(2,nkeys) = p2 + keys(3,nkeys) = h1 + keys(4,nkeys) = h2 + endif + end + +! subroutine orb_range_off_diagonal_single_to_two_rdm_ab_dm(det_1,det_2,c_1,gorb_bitmask,list_orb_reverse,ispin) +! use bitmasks +! BEGIN_DOC +!! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for +!! +!! a given couple of determinant det_1, det_2 being a SINGLE excitation with respect to one another +!! +!! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 +!! +!! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation +!! +!! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +!! +!! ispin determines which spin-spin component of the two-rdm you will update +!! +!! ispin == 1 :: alpha/ alpha +!! ispin == 2 :: beta / beta +!! ispin == 3 :: alpha/ beta +!! ispin == 4 :: spin traced <=> total two-rdm +!! +!! here, only ispin == 3 or 4 will do something +! END_DOC +! implicit none +! integer, intent(in) :: dim1,ispin +! double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) +! integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) +! integer(bit_kind), intent(in) :: orb_bitmask(N_int) +! integer, intent(in) :: list_orb_reverse(mo_num) +! double precision, intent(in) :: c_1 +! +! integer :: occ(N_int*bit_kind_size,2) +! integer :: n_occ_ab(2) +! integer :: i,j,h1,h2,istate,p1 +! integer :: exc(0:2,2,2) +! double precision :: phase +! +! logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace +! logical :: is_integer_in_string +! alpha_alpha = .False. +! beta_beta = .False. +! alpha_beta = .False. +! spin_trace = .False. +! if( ispin == 1)then +! alpha_alpha = .True. +! else if(ispin == 2)then +! beta_beta = .True. +! else if(ispin == 3)then +! alpha_beta = .True. +! else if(ispin == 4)then +! spin_trace = .True. +! endif +! +! call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) +! call get_single_excitation(det_1,det_2,exc,phase,N_int) +! if(alpha_beta)then +! if (exc(0,1,1) == 1) then +! ! Mono alpha +! h1 = exc(1,1,1) +! if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return +! h1 = list_orb_reverse(h1) +! p1 = exc(1,2,1) +! if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return +! p1 = list_orb_reverse(p1) +! do i = 1, n_occ_ab(2) +! h2 = occ(i,2) +! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle +! h2 = list_orb_reverse(h2) +! big_array(h1,h2,p1,h2) += c_1 * phase +! enddo +! else +! ! Mono beta +! h1 = exc(1,1,2) +! if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return +! h1 = list_orb_reverse(h1) +! p1 = exc(1,2,2) +! if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return +! p1 = list_orb_reverse(p1) +! do i = 1, n_occ_ab(1) +! h2 = occ(i,1) +! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle +! h2 = list_orb_reverse(h2) +! big_array(h2,h1,h2,p1) += c_1 * phase +! enddo +! endif +! else if(spin_trace)then +! if (exc(0,1,1) == 1) then +! ! Mono alpha +! h1 = exc(1,1,1) +! if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return +! h1 = list_orb_reverse(h1) +! p1 = exc(1,2,1) +! if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return +! p1 = list_orb_reverse(p1) +! do i = 1, n_occ_ab(2) +! h2 = occ(i,2) +! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle +! h2 = list_orb_reverse(h2) +! big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase +! big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase +! enddo +! else +! ! Mono beta +! h1 = exc(1,1,2) +! if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return +! h1 = list_orb_reverse(h1) +! p1 = exc(1,2,2) +! if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return +! p1 = list_orb_reverse(p1) +! do i = 1, n_occ_ab(1) +! h2 = occ(i,1) +! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle +! h2 = list_orb_reverse(h2) +! big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase +! big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase +! enddo +! endif +! endif +! end + +! subroutine orb_range_off_diagonal_single_to_two_rdm_aa_dm(det_1,det_2,c_1,gorb_bitmask,list_orb_reverse,ispin) +! BEGIN_DOC +!! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for +!! +!! a given couple of determinant det_1, det_2 being a ALPHA SINGLE excitation with respect to one another +!! +!! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 +!! +!! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation +!! +!! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +!! +!! ispin determines which spin-spin component of the two-rdm you will update +!! +!! ispin == 1 :: alpha/ alpha +!! ispin == 2 :: beta / beta +!! ispin == 3 :: alpha/ beta +!! ispin == 4 :: spin traced <=> total two-rdm +!! +!! here, only ispin == 1 or 4 will do something +! END_DOC +! use bitmasks +! implicit none +! integer, intent(in) :: dim1,ispin +! double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) +! integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) +! integer(bit_kind), intent(in) :: orb_bitmask(N_int) +! integer, intent(in) :: list_orb_reverse(mo_num) +! double precision, intent(in) :: c_1 +! +! integer :: occ(N_int*bit_kind_size,2) +! integer :: n_occ_ab(2) +! integer :: i,j,h1,h2,istate,p1 +! integer :: exc(0:2,2,2) +! double precision :: phase +! +! logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace +! logical :: is_integer_in_string +! alpha_alpha = .False. +! beta_beta = .False. +! alpha_beta = .False. +! spin_trace = .False. +! if( ispin == 1)then +! alpha_alpha = .True. +! else if(ispin == 2)then +! beta_beta = .True. +! else if(ispin == 3)then +! alpha_beta = .True. +! else if(ispin == 4)then +! spin_trace = .True. +! endif +! +! call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) +! call get_single_excitation(det_1,det_2,exc,phase,N_int) +! if(alpha_alpha.or.spin_trace)then +! if (exc(0,1,1) == 1) then +! ! Mono alpha +! h1 = exc(1,1,1) +! if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return +! h1 = list_orb_reverse(h1) +! p1 = exc(1,2,1) +! if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return +! p1 = list_orb_reverse(p1) +! do i = 1, n_occ_ab(1) +! h2 = occ(i,1) +! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle +! h2 = list_orb_reverse(h2) +! big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase +! big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase +! +! big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase +! big_array(h2,h1,p1,h2) -= 0.5d0 * c_1 * phase +! enddo +! else +! return +! endif +! endif +! end + +! subroutine orb_range_off_diagonal_single_to_two_rdm_bb_dm(det_1,det_2,c_1,gorb_bitmask,list_orb_reverse,ispin) +! use bitmasks +! BEGIN_DOC +!! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for +!! +!! a given couple of determinant det_1, det_2 being a BETA SINGLE excitation with respect to one another +!! +!! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 +!! +!! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation +!! +!! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +!! +!! ispin determines which spin-spin component of the two-rdm you will update +!! +!! ispin == 1 :: alpha/ alpha +!! ispin == 2 :: beta / beta +!! ispin == 3 :: alpha/ beta +!! ispin == 4 :: spin traced <=> total two-rdm +!! +!! here, only ispin == 2 or 4 will do something +! END_DOC +! implicit none +! integer, intent(in) :: dim1,ispin +! double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) +! integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) +! integer(bit_kind), intent(in) :: orb_bitmask(N_int) +! integer, intent(in) :: list_orb_reverse(mo_num) +! double precision, intent(in) :: c_1 +! +! +! integer :: occ(N_int*bit_kind_size,2) +! integer :: n_occ_ab(2) +! integer :: i,j,h1,h2,istate,p1 +! integer :: exc(0:2,2,2) +! double precision :: phase +! logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace +! logical :: is_integer_in_string +! alpha_alpha = .False. +! beta_beta = .False. +! alpha_beta = .False. +! spin_trace = .False. +! if( ispin == 1)then +! alpha_alpha = .True. +! else if(ispin == 2)then +! beta_beta = .True. +! else if(ispin == 3)then +! alpha_beta = .True. +! else if(ispin == 4)then +! spin_trace = .True. +! endif +! +! +! call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) +! call get_single_excitation(det_1,det_2,exc,phase,N_int) +! if(beta_beta.or.spin_trace)then +! if (exc(0,1,1) == 1) then +! return +! else +! ! Mono beta +! h1 = exc(1,1,2) +! if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return +! h1 = list_orb_reverse(h1) +! p1 = exc(1,2,2) +! if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return +! p1 = list_orb_reverse(p1) +! do istate = 1, N_states +! do i = 1, n_occ_ab(2) +! h2 = occ(i,2) +! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle +! h2 = list_orb_reverse(h2) +! big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase +! big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase +! +! big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase +! big_array(h2,h1,p1,h2) -= 0.5d0 * c_1 * phase +! enddo +! enddo +! endif +! endif +! end + + +! subroutine orb_range_off_diagonal_double_to_two_rdm_aa_dm(det_1,det_2,c_1,gorb_bitmask,list_orb_reverse,ispin) +! use bitmasks +! BEGIN_DOC +!! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for +!! +!! a given couple of determinant det_1, det_2 being a ALPHA/ALPHA DOUBLE excitation with respect to one another +!! +!! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 +!! +!! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation +!! +!! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +!! +!! ispin determines which spin-spin component of the two-rdm you will update +!! +!! ispin == 1 :: alpha/ alpha +!! ispin == 2 :: beta / beta +!! ispin == 3 :: alpha/ beta +!! ispin == 4 :: spin traced <=> total two-rdm +!! +!! here, only ispin == 1 or 4 will do something +! END_DOC +! implicit none +! integer, intent(in) :: dim1,ispin +! double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) +! integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) +! integer(bit_kind), intent(in) :: orb_bitmask(N_int) +! integer, intent(in) :: list_orb_reverse(mo_num) +! double precision, intent(in) :: c_1 +! +! integer :: i,j,h1,h2,p1,p2,istate +! integer :: exc(0:2,2) +! double precision :: phase +! +! logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace +! logical :: is_integer_in_string +! alpha_alpha = .False. +! beta_beta = .False. +! alpha_beta = .False. +! spin_trace = .False. +! if( ispin == 1)then +! alpha_alpha = .True. +! else if(ispin == 2)then +! beta_beta = .True. +! else if(ispin == 3)then +! alpha_beta = .True. +! else if(ispin == 4)then +! spin_trace = .True. +! endif +! call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) +! h1 =exc(1,1) +! if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return +! h1 = list_orb_reverse(h1) +! h2 =exc(2,1) +! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return +! h2 = list_orb_reverse(h2) +! p1 =exc(1,2) +! if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return +! p1 = list_orb_reverse(p1) +! p2 =exc(2,2) +! if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return +! p2 = list_orb_reverse(p2) +! if(alpha_alpha.or.spin_trace)then +! do istate = 1, N_states +! big_array(h1,h2,p1,p2) += 0.5d0 * c_1 * phase +! big_array(h1,h2,p2,p1) -= 0.5d0 * c_1 * phase +! +! big_array(h2,h1,p2,p1) += 0.5d0 * c_1 * phase +! big_array(h2,h1,p1,p2) -= 0.5d0 * c_1 * phase +! enddo +! endif +! end + +! subroutine orb_range_off_diagonal_double_to_two_rdm_bb_dm(det_1,det_2,c_1,gorb_bitmask,list_orb_reverse,ispin) +! use bitmasks +! BEGIN_DOC +!! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for +!! +!! a given couple of determinant det_1, det_2 being a BETA /BETA DOUBLE excitation with respect to one another +!! +!! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 +!! +!! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation +!! +!! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals +!! +!! ispin determines which spin-spin component of the two-rdm you will update +!! +!! ispin == 1 :: alpha/ alpha +!! ispin == 2 :: beta / beta +!! ispin == 3 :: alpha/ beta +!! ispin == 4 :: spin traced <=> total two-rdm +!! +!! here, only ispin == 2 or 4 will do something +! END_DOC +! implicit none +! +! integer, intent(in) :: dim1,ispin +! double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) +! integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) +! integer(bit_kind), intent(in) :: orb_bitmask(N_int) +! integer, intent(in) :: list_orb_reverse(mo_num) +! double precision, intent(in) :: c_1 +! +! integer :: i,j,h1,h2,p1,p2,istate +! integer :: exc(0:2,2) +! double precision :: phase +! logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace +! logical :: is_integer_in_string +! alpha_alpha = .False. +! beta_beta = .False. +! alpha_beta = .False. +! spin_trace = .False. +! if( ispin == 1)then +! alpha_alpha = .True. +! else if(ispin == 2)then +! beta_beta = .True. +! else if(ispin == 3)then +! alpha_beta = .True. +! else if(ispin == 4)then +! spin_trace = .True. +! endif +! +! call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) +! h1 =exc(1,1) +! if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return +! h1 = list_orb_reverse(h1) +! h2 =exc(2,1) +! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return +! h2 = list_orb_reverse(h2) +! p1 =exc(1,2) +! if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return +! p1 = list_orb_reverse(p1) +! p2 =exc(2,2) +! if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return +! p2 = list_orb_reverse(p2) +! if(beta_beta.or.spin_trace)then +! big_array(h1,h2,p1,p2) += 0.5d0 * c_1* phase +! big_array(h1,h2,p2,p1) -= 0.5d0 * c_1* phase +! +! big_array(h2,h1,p2,p1) += 0.5d0 * c_1* phase +! big_array(h2,h1,p1,p2) -= 0.5d0 * c_1* phase +! endif +! end + diff --git a/src/two_body_rdm/two_rdm.irp.f b/src/two_body_rdm/two_rdm.irp.f index 06a8e1e6..c162f365 100644 --- a/src/two_body_rdm/two_rdm.irp.f +++ b/src/two_body_rdm/two_rdm.irp.f @@ -19,7 +19,7 @@ two_rdm_beta_beta_mo = 0.d0 print*,'providing two_rdm_alpha_beta ...' call wall_time(cpu_0) - call all_two_rdm_dm_nstates_openmp(two_rdm_alpha_alpha_mo,two_rdm_beta_beta_mo,two_rdm_alpha_beta_mo,dim1,dim2,dim3,dim4,psi_coef,size(psi_coef,2),size(psi_coef,1)) + call all_two_rdm_dm_nstates(two_rdm_alpha_alpha_mo,two_rdm_beta_beta_mo,two_rdm_alpha_beta_mo,dim1,dim2,dim3,dim4,psi_coef,size(psi_coef,2),size(psi_coef,1)) call wall_time(cpu_1) print*,'two_rdm_alpha_beta provided in',dabs(cpu_1-cpu_0) From 59aaf3806d062f585b4b8a81f1815b23064b0c6f Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Thu, 4 Jul 2019 16:43:08 +0200 Subject: [PATCH 42/59] the alpha/beta single work --- .../orb_range_routines_openmp.irp.f | 12 +- ...utines_compute_2rdm_orb_range_openmp.irp.f | 271 ++++++++++-------- 2 files changed, 163 insertions(+), 120 deletions(-) diff --git a/src/two_body_rdm/orb_range_routines_openmp.irp.f b/src/two_body_rdm/orb_range_routines_openmp.irp.f index 7d791f7c..82649a23 100644 --- a/src/two_body_rdm/orb_range_routines_openmp.irp.f +++ b/src/two_body_rdm/orb_range_routines_openmp.irp.f @@ -353,7 +353,11 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis enddo if(alpha_beta.or.spin_trace.or.alpha_alpha)then ! increment the alpha/beta part for single excitations -!!!! call orb_range_off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + if (nkeys+norb .ge. size(values)) then + call update_keys_values(keys,values,size(values),nkeys,dim1,big_array) + nkeys = 0 + endif + call orb_range_off_diag_single_to_two_rdm_ab_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) ! increment the alpha/alpha part for single excitations !!!! call orb_range_off_diagonal_single_to_two_rdm_aa_dm(tmp_det,tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) endif @@ -445,7 +449,11 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis enddo if(alpha_beta.or.spin_trace.or.beta_beta)then ! increment the alpha/beta part for single excitations -!!!! call orb_range_off_diagonal_single_to_two_rdm_ab_dm(tmp_det, tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + if (nkeys+norb .ge. size(values)) then + call update_keys_values(keys,values,size(values),nkeys,dim1,big_array) + nkeys = 0 + endif + call orb_range_off_diag_single_to_two_rdm_ab_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) ! increment the beta /beta part for single excitations !!!! call orb_range_off_diagonal_single_to_two_rdm_bb_dm(tmp_det, tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) endif diff --git a/src/two_body_rdm/routines_compute_2rdm_orb_range_openmp.irp.f b/src/two_body_rdm/routines_compute_2rdm_orb_range_openmp.irp.f index ae1c3a54..b5bc66b4 100644 --- a/src/two_body_rdm/routines_compute_2rdm_orb_range_openmp.irp.f +++ b/src/two_body_rdm/routines_compute_2rdm_orb_range_openmp.irp.f @@ -255,124 +255,159 @@ endif end -! subroutine orb_range_off_diagonal_single_to_two_rdm_ab_dm(det_1,det_2,c_1,gorb_bitmask,list_orb_reverse,ispin) -! use bitmasks -! BEGIN_DOC -!! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for -!! -!! a given couple of determinant det_1, det_2 being a SINGLE excitation with respect to one another -!! -!! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 -!! -!! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation -!! -!! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals -!! -!! ispin determines which spin-spin component of the two-rdm you will update -!! -!! ispin == 1 :: alpha/ alpha -!! ispin == 2 :: beta / beta -!! ispin == 3 :: alpha/ beta -!! ispin == 4 :: spin traced <=> total two-rdm -!! -!! here, only ispin == 3 or 4 will do something -! END_DOC -! implicit none -! integer, intent(in) :: dim1,ispin -! double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) -! integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) -! integer(bit_kind), intent(in) :: orb_bitmask(N_int) -! integer, intent(in) :: list_orb_reverse(mo_num) -! double precision, intent(in) :: c_1 -! -! integer :: occ(N_int*bit_kind_size,2) -! integer :: n_occ_ab(2) -! integer :: i,j,h1,h2,istate,p1 -! integer :: exc(0:2,2,2) -! double precision :: phase -! -! logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace -! logical :: is_integer_in_string -! alpha_alpha = .False. -! beta_beta = .False. -! alpha_beta = .False. -! spin_trace = .False. -! if( ispin == 1)then -! alpha_alpha = .True. -! else if(ispin == 2)then -! beta_beta = .True. -! else if(ispin == 3)then -! alpha_beta = .True. -! else if(ispin == 4)then -! spin_trace = .True. -! endif -! -! call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) -! call get_single_excitation(det_1,det_2,exc,phase,N_int) -! if(alpha_beta)then -! if (exc(0,1,1) == 1) then -! ! Mono alpha -! h1 = exc(1,1,1) -! if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return -! h1 = list_orb_reverse(h1) -! p1 = exc(1,2,1) -! if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return -! p1 = list_orb_reverse(p1) -! do i = 1, n_occ_ab(2) -! h2 = occ(i,2) -! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle -! h2 = list_orb_reverse(h2) -! big_array(h1,h2,p1,h2) += c_1 * phase -! enddo -! else -! ! Mono beta -! h1 = exc(1,1,2) -! if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return -! h1 = list_orb_reverse(h1) -! p1 = exc(1,2,2) -! if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return -! p1 = list_orb_reverse(p1) -! do i = 1, n_occ_ab(1) -! h2 = occ(i,1) -! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle -! h2 = list_orb_reverse(h2) -! big_array(h2,h1,h2,p1) += c_1 * phase -! enddo -! endif -! else if(spin_trace)then -! if (exc(0,1,1) == 1) then -! ! Mono alpha -! h1 = exc(1,1,1) -! if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return -! h1 = list_orb_reverse(h1) -! p1 = exc(1,2,1) -! if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return -! p1 = list_orb_reverse(p1) -! do i = 1, n_occ_ab(2) -! h2 = occ(i,2) -! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle -! h2 = list_orb_reverse(h2) -! big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase -! big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase -! enddo -! else -! ! Mono beta -! h1 = exc(1,1,2) -! if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return -! h1 = list_orb_reverse(h1) -! p1 = exc(1,2,2) -! if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return -! p1 = list_orb_reverse(p1) -! do i = 1, n_occ_ab(1) -! h2 = occ(i,1) -! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle -! h2 = list_orb_reverse(h2) -! big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase -! big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase -! enddo -! endif -! endif -! end + subroutine orb_range_off_diag_single_to_two_rdm_ab_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + use bitmasks + BEGIN_DOC + ! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for + ! + ! a given couple of determinant det_1, det_2 being a SINGLE excitation with respect to one another + ! + ! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 + ! + ! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation + ! + ! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals + ! + ! ispin determines which spin-spin component of the two-rdm you will update + ! + ! ispin == 1 :: alpha/ alpha + ! ispin == 2 :: beta / beta + ! ispin == 3 :: alpha/ beta + ! ispin == 4 :: spin traced <=> total two-rdm + ! + ! here, only ispin == 3 or 4 will do something + END_DOC + implicit none + integer, intent(in) :: ispin,sze_buff + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(in) :: c_1 + double precision, intent(out) :: values(sze_buff) + integer , intent(out) :: keys(4,sze_buff) + integer , intent(inout):: nkeys + + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,istate,p1 + integer :: exc(0:2,2,2) + double precision :: phase + + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + call get_single_excitation(det_1,det_2,exc,phase,N_int) + if(alpha_beta)then + if (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + if(list_orb_reverse(h1).lt.0)return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,1) + if(list_orb_reverse(p1).lt.0)return + p1 = list_orb_reverse(p1) + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + if(list_orb_reverse(h2).lt.0)return + h2 = list_orb_reverse(h2) + nkeys += 1 + values(nkeys) = c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + enddo + else + ! Mono beta + h1 = exc(1,1,2) + if(list_orb_reverse(h1).lt.0)return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,2) + if(list_orb_reverse(p1).lt.0)return + p1 = list_orb_reverse(p1) + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + if(list_orb_reverse(h2).lt.0)return + h2 = list_orb_reverse(h2) + nkeys += 1 + values(nkeys) = c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + enddo + endif + else if(spin_trace)then + if (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + if(list_orb_reverse(h1).lt.0)return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,1) + if(list_orb_reverse(p1).lt.0)return + p1 = list_orb_reverse(p1) + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + if(list_orb_reverse(h2).lt.0)return + h2 = list_orb_reverse(h2) + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = h2 + keys(4,nkeys) = p1 + enddo + else + ! Mono beta + h1 = exc(1,1,2) + if(list_orb_reverse(h1).lt.0)return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,2) + if(list_orb_reverse(p1).lt.0)return + p1 = list_orb_reverse(p1) + !print*,'****************' + !print*,'****************' + !print*,'h1,p1',h1,p1 + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + if(list_orb_reverse(h2).lt.0)return + h2 = list_orb_reverse(h2) + ! print*,'h2 = ',h2 + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = h2 + keys(4,nkeys) = p1 + enddo + endif + endif + end ! subroutine orb_range_off_diagonal_single_to_two_rdm_aa_dm(det_1,det_2,c_1,gorb_bitmask,list_orb_reverse,ispin) ! BEGIN_DOC From 887afe97b44718c232e4b6bd1b46f5f7af49e5e9 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Thu, 4 Jul 2019 17:34:56 +0200 Subject: [PATCH 43/59] two rdm seems to work with buffer, ready for openmp --- src/bitmask/core_inact_act_virt.irp.f | 1 + src/two_body_rdm/orb_range_routines.irp.f | 2 + .../orb_range_routines_openmp.irp.f | 35 +- .../routines_compute_2rdm_orb_range.irp.f | 38 +- ...utines_compute_2rdm_orb_range_openmp.irp.f | 699 ++++++++++-------- 5 files changed, 440 insertions(+), 335 deletions(-) diff --git a/src/bitmask/core_inact_act_virt.irp.f b/src/bitmask/core_inact_act_virt.irp.f index ff7ee2de..b016f1fd 100644 --- a/src/bitmask/core_inact_act_virt.irp.f +++ b/src/bitmask/core_inact_act_virt.irp.f @@ -322,6 +322,7 @@ END_PROVIDER enddo print *, 'Active MOs:' print *, list_act(1:n_act_orb) + print*, list_act_reverse(1:n_act_orb) END_PROVIDER diff --git a/src/two_body_rdm/orb_range_routines.irp.f b/src/two_body_rdm/orb_range_routines.irp.f index d5bd7d1c..d63a0390 100644 --- a/src/two_body_rdm/orb_range_routines.irp.f +++ b/src/two_body_rdm/orb_range_routines.irp.f @@ -30,6 +30,7 @@ subroutine orb_range_two_rdm_state_av(big_array,dim1,norb,list_orb,list_orb_reve u_t, & size(u_t, 1), & N_det, N_st) + call orb_range_two_rdm_state_av_work(big_array,dim1,norb,list_orb,list_orb_reverse,state_weights,ispin,u_t,N_st,sze,1,N_det,0,1) deallocate(u_t) @@ -135,6 +136,7 @@ subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,l stop endif + PROVIDE N_int call list_to_bitstring( orb_bitmask, list_orb, norb, N_int) diff --git a/src/two_body_rdm/orb_range_routines_openmp.irp.f b/src/two_body_rdm/orb_range_routines_openmp.irp.f index 82649a23..b4ff7405 100644 --- a/src/two_body_rdm/orb_range_routines_openmp.irp.f +++ b/src/two_body_rdm/orb_range_routines_openmp.irp.f @@ -145,7 +145,7 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis PROVIDE N_int call list_to_bitstring( orb_bitmask, list_orb, norb, N_int) - sze_buff = norb ** 3 + sze_buff = norb ** 3 + 6 * norb list_orb_reverse = -1000 do i = 1, norb list_orb_reverse(list_orb(i)) = i @@ -353,13 +353,17 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis enddo if(alpha_beta.or.spin_trace.or.alpha_alpha)then ! increment the alpha/beta part for single excitations - if (nkeys+norb .ge. size(values)) then - call update_keys_values(keys,values,size(values),nkeys,dim1,big_array) - nkeys = 0 - endif + if (nkeys+ 2 * norb .ge. size(values)) then + call update_keys_values(keys,values,size(values),nkeys,dim1,big_array) + nkeys = 0 + endif call orb_range_off_diag_single_to_two_rdm_ab_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) ! increment the alpha/alpha part for single excitations -!!!! call orb_range_off_diagonal_single_to_two_rdm_aa_dm(tmp_det,tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + if (nkeys+2 * norb .ge. size(values)) then + call update_keys_values(keys,values,size(values),nkeys,dim1,big_array) + nkeys = 0 + endif + call orb_range_off_diag_single_to_two_rdm_aa_dm_buffer(tmp_det,tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) endif enddo @@ -382,7 +386,11 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis c_2(l) = u_t(l,k_a) c_average += c_1(l) * c_2(l) * state_weights(l) enddo -!!!! call orb_range_off_diagonal_double_to_two_rdm_aa_dm(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + if (nkeys+4 .ge. size(values)) then + call update_keys_values(keys,values,size(values),nkeys,dim1,big_array) + nkeys = 0 + endif + call orb_range_off_diag_double_to_two_rdm_aa_dm_buffer(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) enddo endif @@ -455,7 +463,11 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis endif call orb_range_off_diag_single_to_two_rdm_ab_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) ! increment the beta /beta part for single excitations -!!!! call orb_range_off_diagonal_single_to_two_rdm_bb_dm(tmp_det, tmp_det2,c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + if (nkeys+norb .ge. size(values)) then + call update_keys_values(keys,values,size(values),nkeys,dim1,big_array) + nkeys = 0 + endif + call orb_range_off_diag_single_to_two_rdm_bb_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) endif enddo @@ -477,7 +489,12 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis c_2(l) = u_t(l,k_a) c_average += c_1(l) * c_2(l) * state_weights(l) enddo -!!!! call orb_range_off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_alpha_unique(1, lcol),c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) +! call orb_range_off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_alpha_unique(1, lcol),c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + if (nkeys+4 .ge. size(values)) then + call update_keys_values(keys,values,size(values),nkeys,dim1,big_array) + nkeys = 0 + endif + call orb_range_off_diag_double_to_two_rdm_bb_dm_buffer(tmp_det(1,2),psi_det_alpha_unique(1, lcol),c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) ASSERT (l_a <= N_det) enddo diff --git a/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f b/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f index a3c7a76d..52cccbf3 100644 --- a/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f +++ b/src/two_body_rdm/routines_compute_2rdm_orb_range.irp.f @@ -13,7 +13,7 @@ double precision, intent(in) :: c_1 integer :: occ(N_int*bit_kind_size,2) integer :: n_occ_ab(2) - integer :: i,j,h1,h2,istate + integer :: i,j,h1,h2 call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) do i = 1, n_occ_ab(1) h1 = occ(i,1) @@ -53,7 +53,7 @@ integer :: occ(N_int*bit_kind_size,2) integer :: n_occ_ab(2) - integer :: i,j,h1,h2,istate + integer :: i,j,h1,h2 integer(bit_kind) :: det_1_act(N_int,2) logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace do i = 1, N_int @@ -193,7 +193,7 @@ integer(bit_kind), intent(in) :: orb_bitmask(N_int) integer, intent(in) :: list_orb_reverse(mo_num) double precision, intent(in) :: c_1 - integer :: i,j,h1,h2,p1,p2,istate + integer :: i,j,h1,h2,p1,p2 integer :: exc(0:2,2,2) double precision :: phase logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace @@ -278,7 +278,7 @@ integer :: occ(N_int*bit_kind_size,2) integer :: n_occ_ab(2) - integer :: i,j,h1,h2,istate,p1 + integer :: i,j,h1,h2,p1 integer :: exc(0:2,2,2) double precision :: phase @@ -397,7 +397,7 @@ integer :: occ(N_int*bit_kind_size,2) integer :: n_occ_ab(2) - integer :: i,j,h1,h2,istate,p1 + integer :: i,j,h1,h2,p1 integer :: exc(0:2,2,2) double precision :: phase @@ -477,7 +477,7 @@ integer :: occ(N_int*bit_kind_size,2) integer :: n_occ_ab(2) - integer :: i,j,h1,h2,istate,p1 + integer :: i,j,h1,h2,p1 integer :: exc(0:2,2,2) double precision :: phase logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace @@ -510,18 +510,16 @@ p1 = exc(1,2,2) if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return p1 = list_orb_reverse(p1) - do istate = 1, N_states - do i = 1, n_occ_ab(2) - h2 = occ(i,2) - if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle - h2 = list_orb_reverse(h2) - big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase - big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle + h2 = list_orb_reverse(h2) + big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase + big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase - big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase - big_array(h2,h1,p1,h2) -= 0.5d0 * c_1 * phase - enddo - enddo + big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase + big_array(h2,h1,p1,h2) -= 0.5d0 * c_1 * phase + enddo endif endif end @@ -557,7 +555,7 @@ integer, intent(in) :: list_orb_reverse(mo_num) double precision, intent(in) :: c_1 - integer :: i,j,h1,h2,p1,p2,istate + integer :: i,j,h1,h2,p1,p2 integer :: exc(0:2,2) double precision :: phase @@ -590,13 +588,11 @@ if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return p2 = list_orb_reverse(p2) if(alpha_alpha.or.spin_trace)then - do istate = 1, N_states big_array(h1,h2,p1,p2) += 0.5d0 * c_1 * phase big_array(h1,h2,p2,p1) -= 0.5d0 * c_1 * phase big_array(h2,h1,p2,p1) += 0.5d0 * c_1 * phase big_array(h2,h1,p1,p2) -= 0.5d0 * c_1 * phase - enddo endif end @@ -631,7 +627,7 @@ integer, intent(in) :: list_orb_reverse(mo_num) double precision, intent(in) :: c_1 - integer :: i,j,h1,h2,p1,p2,istate + integer :: i,j,h1,h2,p1,p2 integer :: exc(0:2,2) double precision :: phase logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace diff --git a/src/two_body_rdm/routines_compute_2rdm_orb_range_openmp.irp.f b/src/two_body_rdm/routines_compute_2rdm_orb_range_openmp.irp.f index b5bc66b4..ffbb2711 100644 --- a/src/two_body_rdm/routines_compute_2rdm_orb_range_openmp.irp.f +++ b/src/two_body_rdm/routines_compute_2rdm_orb_range_openmp.irp.f @@ -26,7 +26,7 @@ integer :: occ(N_int*bit_kind_size,2) integer :: n_occ_ab(2) - integer :: i,j,h1,h2,istate + integer :: i,j,h1,h2 integer(bit_kind) :: det_1_act(N_int,2) logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace do i = 1, N_int @@ -201,7 +201,7 @@ double precision, intent(out) :: values(sze_buff) integer , intent(out) :: keys(4,sze_buff) integer , intent(inout):: nkeys - integer :: i,j,h1,h2,p1,p2,istate + integer :: i,j,h1,h2,p1,p2 integer :: exc(0:2,2,2) double precision :: phase logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace @@ -288,7 +288,7 @@ integer :: occ(N_int*bit_kind_size,2) integer :: n_occ_ab(2) - integer :: i,j,h1,h2,istate,p1 + integer :: i,j,h1,h2,p1 integer :: exc(0:2,2,2) double precision :: phase @@ -409,310 +409,399 @@ endif end -! subroutine orb_range_off_diagonal_single_to_two_rdm_aa_dm(det_1,det_2,c_1,gorb_bitmask,list_orb_reverse,ispin) -! BEGIN_DOC -!! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for -!! -!! a given couple of determinant det_1, det_2 being a ALPHA SINGLE excitation with respect to one another -!! -!! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 -!! -!! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation -!! -!! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals -!! -!! ispin determines which spin-spin component of the two-rdm you will update -!! -!! ispin == 1 :: alpha/ alpha -!! ispin == 2 :: beta / beta -!! ispin == 3 :: alpha/ beta -!! ispin == 4 :: spin traced <=> total two-rdm -!! -!! here, only ispin == 1 or 4 will do something -! END_DOC -! use bitmasks -! implicit none -! integer, intent(in) :: dim1,ispin -! double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) -! integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) -! integer(bit_kind), intent(in) :: orb_bitmask(N_int) -! integer, intent(in) :: list_orb_reverse(mo_num) -! double precision, intent(in) :: c_1 -! -! integer :: occ(N_int*bit_kind_size,2) -! integer :: n_occ_ab(2) -! integer :: i,j,h1,h2,istate,p1 -! integer :: exc(0:2,2,2) -! double precision :: phase -! -! logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace -! logical :: is_integer_in_string -! alpha_alpha = .False. -! beta_beta = .False. -! alpha_beta = .False. -! spin_trace = .False. -! if( ispin == 1)then -! alpha_alpha = .True. -! else if(ispin == 2)then -! beta_beta = .True. -! else if(ispin == 3)then -! alpha_beta = .True. -! else if(ispin == 4)then -! spin_trace = .True. -! endif -! -! call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) -! call get_single_excitation(det_1,det_2,exc,phase,N_int) -! if(alpha_alpha.or.spin_trace)then -! if (exc(0,1,1) == 1) then -! ! Mono alpha -! h1 = exc(1,1,1) -! if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return -! h1 = list_orb_reverse(h1) -! p1 = exc(1,2,1) -! if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return -! p1 = list_orb_reverse(p1) -! do i = 1, n_occ_ab(1) -! h2 = occ(i,1) -! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle -! h2 = list_orb_reverse(h2) -! big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase -! big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase -! -! big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase -! big_array(h2,h1,p1,h2) -= 0.5d0 * c_1 * phase -! enddo -! else -! return -! endif -! endif -! end + subroutine orb_range_off_diag_single_to_two_rdm_aa_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + BEGIN_DOC + ! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for + ! + ! a given couple of determinant det_1, det_2 being a ALPHA SINGLE excitation with respect to one another + ! + ! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 + ! + ! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation + ! + ! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals + ! + ! ispin determines which spin-spin component of the two-rdm you will update + ! + ! ispin == 1 :: alpha/ alpha + ! ispin == 2 :: beta / beta + ! ispin == 3 :: alpha/ beta + ! ispin == 4 :: spin traced <=> total two-rdm + ! + ! here, only ispin == 1 or 4 will do something + END_DOC + use bitmasks + implicit none + integer, intent(in) :: ispin,sze_buff + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(in) :: c_1 + double precision, intent(out) :: values(sze_buff) + integer , intent(out) :: keys(4,sze_buff) + integer , intent(inout):: nkeys + + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,p1 + integer :: exc(0:2,2,2) + double precision :: phase + + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + call get_single_excitation(det_1,det_2,exc,phase,N_int) + if(alpha_alpha.or.spin_trace)then + if (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + if(list_orb_reverse(h1).lt.0)return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,1) + if(list_orb_reverse(p1).lt.0)return + p1 = list_orb_reverse(p1) + do i = 1, n_occ_ab(1) + h2 = occ(i,1) + if(list_orb_reverse(h2).lt.0)return + h2 = list_orb_reverse(h2) -! subroutine orb_range_off_diagonal_single_to_two_rdm_bb_dm(det_1,det_2,c_1,gorb_bitmask,list_orb_reverse,ispin) -! use bitmasks -! BEGIN_DOC -!! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for -!! -!! a given couple of determinant det_1, det_2 being a BETA SINGLE excitation with respect to one another -!! -!! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 -!! -!! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation -!! -!! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals -!! -!! ispin determines which spin-spin component of the two-rdm you will update -!! -!! ispin == 1 :: alpha/ alpha -!! ispin == 2 :: beta / beta -!! ispin == 3 :: alpha/ beta -!! ispin == 4 :: spin traced <=> total two-rdm -!! -!! here, only ispin == 2 or 4 will do something -! END_DOC -! implicit none -! integer, intent(in) :: dim1,ispin -! double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) -! integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) -! integer(bit_kind), intent(in) :: orb_bitmask(N_int) -! integer, intent(in) :: list_orb_reverse(mo_num) -! double precision, intent(in) :: c_1 -! -! -! integer :: occ(N_int*bit_kind_size,2) -! integer :: n_occ_ab(2) -! integer :: i,j,h1,h2,istate,p1 -! integer :: exc(0:2,2,2) -! double precision :: phase -! logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace -! logical :: is_integer_in_string -! alpha_alpha = .False. -! beta_beta = .False. -! alpha_beta = .False. -! spin_trace = .False. -! if( ispin == 1)then -! alpha_alpha = .True. -! else if(ispin == 2)then -! beta_beta = .True. -! else if(ispin == 3)then -! alpha_beta = .True. -! else if(ispin == 4)then -! spin_trace = .True. -! endif -! -! -! call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) -! call get_single_excitation(det_1,det_2,exc,phase,N_int) -! if(beta_beta.or.spin_trace)then -! if (exc(0,1,1) == 1) then -! return -! else -! ! Mono beta -! h1 = exc(1,1,2) -! if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return -! h1 = list_orb_reverse(h1) -! p1 = exc(1,2,2) -! if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return -! p1 = list_orb_reverse(p1) -! do istate = 1, N_states -! do i = 1, n_occ_ab(2) -! h2 = occ(i,2) -! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))cycle -! h2 = list_orb_reverse(h2) -! big_array(h1,h2,p1,h2) += 0.5d0 * c_1 * phase -! big_array(h1,h2,h2,p1) -= 0.5d0 * c_1 * phase -! -! big_array(h2,h1,h2,p1) += 0.5d0 * c_1 * phase -! big_array(h2,h1,p1,h2) -= 0.5d0 * c_1 * phase -! enddo -! enddo -! endif -! endif -! end + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + + nkeys += 1 + values(nkeys) = - 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = h2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = - 0.5d0 * c_1 * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + enddo + else + return + endif + endif + end + + subroutine orb_range_off_diag_single_to_two_rdm_bb_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + use bitmasks + BEGIN_DOC + ! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for + ! + ! a given couple of determinant det_1, det_2 being a BETA SINGLE excitation with respect to one another + ! + ! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 + ! + ! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation + ! + ! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals + ! + ! ispin determines which spin-spin component of the two-rdm you will update + ! + ! ispin == 1 :: alpha/ alpha + ! ispin == 2 :: beta / beta + ! ispin == 3 :: alpha/ beta + ! ispin == 4 :: spin traced <=> total two-rdm + ! + ! here, only ispin == 2 or 4 will do something + END_DOC + implicit none + integer, intent(in) :: ispin,sze_buff + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(in) :: c_1 + double precision, intent(out) :: values(sze_buff) + integer , intent(out) :: keys(4,sze_buff) + integer , intent(inout):: nkeys + + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2) + integer :: i,j,h1,h2,p1 + integer :: exc(0:2,2,2) + double precision :: phase + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + + + call bitstring_to_list_ab(det_1, occ, n_occ_ab, N_int) + call get_single_excitation(det_1,det_2,exc,phase,N_int) + if(beta_beta.or.spin_trace)then + if (exc(0,1,1) == 1) then + return + else + ! Mono beta + h1 = exc(1,1,2) + if(list_orb_reverse(h1).lt.0)return + h1 = list_orb_reverse(h1) + p1 = exc(1,2,2) + if(list_orb_reverse(p1).lt.0)return + p1 = list_orb_reverse(p1) + do i = 1, n_occ_ab(2) + h2 = occ(i,2) + if(list_orb_reverse(h2).lt.0)return + h2 = list_orb_reverse(h2) + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + + nkeys += 1 + values(nkeys) = - 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = h2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = h2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = - 0.5d0 * c_1 * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + enddo + endif + endif + end -! subroutine orb_range_off_diagonal_double_to_two_rdm_aa_dm(det_1,det_2,c_1,gorb_bitmask,list_orb_reverse,ispin) -! use bitmasks -! BEGIN_DOC -!! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for -!! -!! a given couple of determinant det_1, det_2 being a ALPHA/ALPHA DOUBLE excitation with respect to one another -!! -!! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 -!! -!! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation -!! -!! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals -!! -!! ispin determines which spin-spin component of the two-rdm you will update -!! -!! ispin == 1 :: alpha/ alpha -!! ispin == 2 :: beta / beta -!! ispin == 3 :: alpha/ beta -!! ispin == 4 :: spin traced <=> total two-rdm -!! -!! here, only ispin == 1 or 4 will do something -! END_DOC -! implicit none -! integer, intent(in) :: dim1,ispin -! double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) -! integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) -! integer(bit_kind), intent(in) :: orb_bitmask(N_int) -! integer, intent(in) :: list_orb_reverse(mo_num) -! double precision, intent(in) :: c_1 -! -! integer :: i,j,h1,h2,p1,p2,istate -! integer :: exc(0:2,2) -! double precision :: phase -! -! logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace -! logical :: is_integer_in_string -! alpha_alpha = .False. -! beta_beta = .False. -! alpha_beta = .False. -! spin_trace = .False. -! if( ispin == 1)then -! alpha_alpha = .True. -! else if(ispin == 2)then -! beta_beta = .True. -! else if(ispin == 3)then -! alpha_beta = .True. -! else if(ispin == 4)then -! spin_trace = .True. -! endif -! call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) -! h1 =exc(1,1) -! if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return -! h1 = list_orb_reverse(h1) -! h2 =exc(2,1) -! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return -! h2 = list_orb_reverse(h2) -! p1 =exc(1,2) -! if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return -! p1 = list_orb_reverse(p1) -! p2 =exc(2,2) -! if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return -! p2 = list_orb_reverse(p2) -! if(alpha_alpha.or.spin_trace)then -! do istate = 1, N_states -! big_array(h1,h2,p1,p2) += 0.5d0 * c_1 * phase -! big_array(h1,h2,p2,p1) -= 0.5d0 * c_1 * phase -! -! big_array(h2,h1,p2,p1) += 0.5d0 * c_1 * phase -! big_array(h2,h1,p1,p2) -= 0.5d0 * c_1 * phase -! enddo -! endif -! end + subroutine orb_range_off_diag_double_to_two_rdm_aa_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + use bitmasks + BEGIN_DOC + ! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for + ! + ! a given couple of determinant det_1, det_2 being a ALPHA/ALPHA DOUBLE excitation with respect to one another + ! + ! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 + ! + ! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation + ! + ! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals + ! + ! ispin determines which spin-spin component of the two-rdm you will update + ! + ! ispin == 1 :: alpha/ alpha + ! ispin == 2 :: beta / beta + ! ispin == 3 :: alpha/ beta + ! ispin == 4 :: spin traced <=> total two-rdm + ! + ! here, only ispin == 1 or 4 will do something + END_DOC + implicit none + integer, intent(in) :: ispin,sze_buff + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(in) :: c_1 + double precision, intent(out) :: values(sze_buff) + integer , intent(out) :: keys(4,sze_buff) + integer , intent(inout):: nkeys + + + integer :: i,j,h1,h2,p1,p2 + integer :: exc(0:2,2) + double precision :: phase + + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) + h1 =exc(1,1) + if(list_orb_reverse(h1).lt.0)return + h1 = list_orb_reverse(h1) + h2 =exc(2,1) + if(list_orb_reverse(h2).lt.0)return + h2 = list_orb_reverse(h2) + p1 =exc(1,2) + if(list_orb_reverse(p1).lt.0)return + p1 = list_orb_reverse(p1) + p2 =exc(2,2) + if(list_orb_reverse(p2).lt.0)return + p2 = list_orb_reverse(p2) + if(alpha_alpha.or.spin_trace)then + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 -! subroutine orb_range_off_diagonal_double_to_two_rdm_bb_dm(det_1,det_2,c_1,gorb_bitmask,list_orb_reverse,ispin) -! use bitmasks -! BEGIN_DOC -!! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for -!! -!! a given couple of determinant det_1, det_2 being a BETA /BETA DOUBLE excitation with respect to one another -!! -!! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 -!! -!! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation -!! -!! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals -!! -!! ispin determines which spin-spin component of the two-rdm you will update -!! -!! ispin == 1 :: alpha/ alpha -!! ispin == 2 :: beta / beta -!! ispin == 3 :: alpha/ beta -!! ispin == 4 :: spin traced <=> total two-rdm -!! -!! here, only ispin == 2 or 4 will do something -! END_DOC -! implicit none -! -! integer, intent(in) :: dim1,ispin -! double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) -! integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) -! integer(bit_kind), intent(in) :: orb_bitmask(N_int) -! integer, intent(in) :: list_orb_reverse(mo_num) -! double precision, intent(in) :: c_1 -! -! integer :: i,j,h1,h2,p1,p2,istate -! integer :: exc(0:2,2) -! double precision :: phase -! logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace -! logical :: is_integer_in_string -! alpha_alpha = .False. -! beta_beta = .False. -! alpha_beta = .False. -! spin_trace = .False. -! if( ispin == 1)then -! alpha_alpha = .True. -! else if(ispin == 2)then -! beta_beta = .True. -! else if(ispin == 3)then -! alpha_beta = .True. -! else if(ispin == 4)then -! spin_trace = .True. -! endif -! -! call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) -! h1 =exc(1,1) -! if(.not.is_integer_in_string(h1,orb_bitmask,N_int))return -! h1 = list_orb_reverse(h1) -! h2 =exc(2,1) -! if(.not.is_integer_in_string(h2,orb_bitmask,N_int))return -! h2 = list_orb_reverse(h2) -! p1 =exc(1,2) -! if(.not.is_integer_in_string(p1,orb_bitmask,N_int))return -! p1 = list_orb_reverse(p1) -! p2 =exc(2,2) -! if(.not.is_integer_in_string(p2,orb_bitmask,N_int))return -! p2 = list_orb_reverse(p2) -! if(beta_beta.or.spin_trace)then -! big_array(h1,h2,p1,p2) += 0.5d0 * c_1* phase -! big_array(h1,h2,p2,p1) -= 0.5d0 * c_1* phase -! -! big_array(h2,h1,p2,p1) += 0.5d0 * c_1* phase -! big_array(h2,h1,p1,p2) -= 0.5d0 * c_1* phase -! endif -! end + nkeys += 1 + values(nkeys) = - 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = - 0.5d0 * c_1 * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + endif + end + + subroutine orb_range_off_diag_double_to_two_rdm_bb_dm_buffer(det_1,det_2,c_1,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + use bitmasks + BEGIN_DOC + ! routine that update the OFF DIAGONAL PART of the two body rdms in a specific range of orbitals for + ! + ! a given couple of determinant det_1, det_2 being a BETA /BETA DOUBLE excitation with respect to one another + ! + ! c_1 is supposed to be a scalar quantity, such as state averaged coef of the determinant det_1 + ! + ! big_array(dim1,dim1,dim1,dim1) is the two-body rdm to be updated in physicist notation + ! + ! orb_bitmask(N_int) is the bitmask for the orbital range, list_orb_reverse(mo_num) is the inverse range of orbitals + ! + ! ispin determines which spin-spin component of the two-rdm you will update + ! + ! ispin == 1 :: alpha/ alpha + ! ispin == 2 :: beta / beta + ! ispin == 3 :: alpha/ beta + ! ispin == 4 :: spin traced <=> total two-rdm + ! + ! here, only ispin == 2 or 4 will do something + END_DOC + implicit none + + integer, intent(in) :: ispin,sze_buff + integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer, intent(in) :: list_orb_reverse(mo_num) + double precision, intent(in) :: c_1 + double precision, intent(out) :: values(sze_buff) + integer , intent(out) :: keys(4,sze_buff) + integer , intent(inout):: nkeys + + integer :: i,j,h1,h2,p1,p2 + integer :: exc(0:2,2) + double precision :: phase + logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace + logical :: is_integer_in_string + alpha_alpha = .False. + beta_beta = .False. + alpha_beta = .False. + spin_trace = .False. + if( ispin == 1)then + alpha_alpha = .True. + else if(ispin == 2)then + beta_beta = .True. + else if(ispin == 3)then + alpha_beta = .True. + else if(ispin == 4)then + spin_trace = .True. + endif + + call get_double_excitation_spin(det_1,det_2,exc,phase,N_int) + h1 =exc(1,1) + if(list_orb_reverse(h1).lt.0)return + h1 = list_orb_reverse(h1) + h2 =exc(2,1) + if(list_orb_reverse(h2).lt.0)return + h2 = list_orb_reverse(h2) + p1 =exc(1,2) + if(list_orb_reverse(p1).lt.0)return + p1 = list_orb_reverse(p1) + p2 =exc(2,2) + if(list_orb_reverse(p2).lt.0)return + p2 = list_orb_reverse(p2) + if(beta_beta.or.spin_trace)then + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + + nkeys += 1 + values(nkeys) = - 0.5d0 * c_1 * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = 0.5d0 * c_1 * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = - 0.5d0 * c_1 * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + endif + end From e3779e3c634d8485f59c6ad7b38c7e45e3b881bd Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Thu, 4 Jul 2019 18:04:43 +0200 Subject: [PATCH 44/59] bug fixed in openmp 2 rdms --- src/two_body_rdm/all_2rdm_routines.irp.f | 2 +- src/two_body_rdm/all_states_routines.irp.f | 2 +- src/two_body_rdm/orb_range_routines.irp.f | 2 +- .../orb_range_routines_openmp.irp.f | 27 +++++++------------ ...utines_compute_2rdm_orb_range_openmp.irp.f | 4 +-- 5 files changed, 14 insertions(+), 23 deletions(-) diff --git a/src/two_body_rdm/all_2rdm_routines.irp.f b/src/two_body_rdm/all_2rdm_routines.irp.f index 5127e31f..fa036e6a 100644 --- a/src/two_body_rdm/all_2rdm_routines.irp.f +++ b/src/two_body_rdm/all_2rdm_routines.irp.f @@ -392,7 +392,7 @@ subroutine all_two_rdm_dm_nstates_work_$N_int(big_array_aa,big_array_bb,big_arra c_1(l) = u_t(l,l_a) c_2(l) = u_t(l,k_a) enddo - call off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_alpha_unique(1, lcol),c_1,c_2,big_array_bb,dim1,dim2,dim3,dim4) + call off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_beta_unique(1, lcol),c_1,c_2,big_array_bb,dim1,dim2,dim3,dim4) ASSERT (l_a <= N_det) enddo diff --git a/src/two_body_rdm/all_states_routines.irp.f b/src/two_body_rdm/all_states_routines.irp.f index af7cafc2..8f40f32a 100644 --- a/src/two_body_rdm/all_states_routines.irp.f +++ b/src/two_body_rdm/all_states_routines.irp.f @@ -442,7 +442,7 @@ subroutine orb_range_all_states_two_rdm_work_$N_int(big_array,dim1,norb,list_orb c_2(l) = u_t(l,k_a) c_contrib(l) = c_1(l) * c_2(l) enddo - call orb_range_off_diagonal_double_to_two_rdm_bb_dm_all_states(tmp_det(1,2),psi_det_alpha_unique(1, lcol),c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + call orb_range_off_diagonal_double_to_two_rdm_bb_dm_all_states(tmp_det(1,2),psi_det_beta_unique(1, lcol),c_contrib,N_st,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) ASSERT (l_a <= N_det) enddo diff --git a/src/two_body_rdm/orb_range_routines.irp.f b/src/two_body_rdm/orb_range_routines.irp.f index d63a0390..a8684185 100644 --- a/src/two_body_rdm/orb_range_routines.irp.f +++ b/src/two_body_rdm/orb_range_routines.irp.f @@ -445,7 +445,7 @@ subroutine orb_range_two_rdm_state_av_work_$N_int(big_array,dim1,norb,list_orb,l c_2(l) = u_t(l,k_a) c_average += c_1(l) * c_2(l) * state_weights(l) enddo - call orb_range_off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_alpha_unique(1, lcol),c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) + call orb_range_off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_beta_unique(1, lcol),c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) ASSERT (l_a <= N_det) enddo diff --git a/src/two_body_rdm/orb_range_routines_openmp.irp.f b/src/two_body_rdm/orb_range_routines_openmp.irp.f index b4ff7405..ba22e37d 100644 --- a/src/two_body_rdm/orb_range_routines_openmp.irp.f +++ b/src/two_body_rdm/orb_range_routines_openmp.irp.f @@ -93,11 +93,9 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) integer :: i,j,k,l - integer :: k_a, k_b, l_a, l_b, m_a, m_b - integer :: istate - integer :: krow, kcol, krow_b, kcol_b + integer :: k_a, k_b, l_a, l_b + integer :: krow, kcol integer :: lrow, lcol - integer :: mrow, mcol integer(bit_kind) :: spindet($N_int) integer(bit_kind) :: tmp_det($N_int,2) integer(bit_kind) :: tmp_det2($N_int,2) @@ -109,7 +107,6 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis integer, allocatable :: singles_b(:) integer, allocatable :: idx(:), idx0(:) integer :: maxab, n_singles_a, n_singles_b, kcol_prev - integer*8 :: k8 double precision :: c_average logical :: alpha_alpha,beta_beta,alpha_beta,spin_trace @@ -136,11 +133,6 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis stop endif - !do i = 1, N_int - ! det_1_act(i,1) = iand(det_1(i,1),orb_bitmask(i)) - ! det_1_act(i,2) = iand(det_1(i,2),orb_bitmask(i)) - !enddo - PROVIDE N_int @@ -173,13 +165,13 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis ! !$OMP psi_bilinear_matrix_columns_loc, & ! !$OMP psi_bilinear_matrix_transp_rows_loc, & ! !$OMP istart, iend, istep, irp_here, v_t, s_t, & - ! !$OMP ishift, idx0, u_t, maxab) & + ! !$OMP ishift, idx0, u_t, maxab, alpha_alpha,beta_beta,alpha_beta,spin_trace,ispin) & ! !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,& ! !$OMP lcol, lrow, l_a, l_b, & ! !$OMP buffer, doubles, n_doubles, & ! !$OMP tmp_det2, idx, l, kcol_prev, & ! !$OMP singles_a, n_singles_a, singles_b, & - ! !$OMP n_singles_b, k8) + ! !$OMP n_singles_b, nkeys, keys, valus, c_average) ! Alpha/Beta double excitations ! ============================= @@ -359,7 +351,7 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis endif call orb_range_off_diag_single_to_two_rdm_ab_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) ! increment the alpha/alpha part for single excitations - if (nkeys+2 * norb .ge. size(values)) then + if (nkeys+4 * norb .ge. size(values)) then call update_keys_values(keys,values,size(values),nkeys,dim1,big_array) nkeys = 0 endif @@ -457,13 +449,13 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis enddo if(alpha_beta.or.spin_trace.or.beta_beta)then ! increment the alpha/beta part for single excitations - if (nkeys+norb .ge. size(values)) then + if (nkeys+2 * norb .ge. size(values)) then call update_keys_values(keys,values,size(values),nkeys,dim1,big_array) nkeys = 0 endif call orb_range_off_diag_single_to_two_rdm_ab_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) ! increment the beta /beta part for single excitations - if (nkeys+norb .ge. size(values)) then + if (nkeys+4 * norb .ge. size(values)) then call update_keys_values(keys,values,size(values),nkeys,dim1,big_array) nkeys = 0 endif @@ -489,12 +481,11 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis c_2(l) = u_t(l,k_a) c_average += c_1(l) * c_2(l) * state_weights(l) enddo -! call orb_range_off_diagonal_double_to_two_rdm_bb_dm(tmp_det(1,2),psi_det_alpha_unique(1, lcol),c_average,big_array,dim1,orb_bitmask,list_orb_reverse,ispin) if (nkeys+4 .ge. size(values)) then call update_keys_values(keys,values,size(values),nkeys,dim1,big_array) nkeys = 0 endif - call orb_range_off_diag_double_to_two_rdm_bb_dm_buffer(tmp_det(1,2),psi_det_alpha_unique(1, lcol),c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) + call orb_range_off_diag_double_to_two_rdm_bb_dm_buffer(tmp_det(1,2),psi_det_beta_unique(1, lcol),c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) ASSERT (l_a <= N_det) enddo @@ -534,7 +525,7 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis end do !!$OMP END DO - deallocate(buffer, singles_a, singles_b, doubles, idx) + deallocate(buffer, singles_a, singles_b, doubles, idx, keys, values) !!$OMP END PARALLEL end diff --git a/src/two_body_rdm/routines_compute_2rdm_orb_range_openmp.irp.f b/src/two_body_rdm/routines_compute_2rdm_orb_range_openmp.irp.f index ffbb2711..0ba934d7 100644 --- a/src/two_body_rdm/routines_compute_2rdm_orb_range_openmp.irp.f +++ b/src/two_body_rdm/routines_compute_2rdm_orb_range_openmp.irp.f @@ -639,7 +639,7 @@ END_DOC implicit none integer, intent(in) :: ispin,sze_buff - integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) integer, intent(in) :: list_orb_reverse(mo_num) double precision, intent(in) :: c_1 double precision, intent(out) :: values(sze_buff) @@ -735,7 +735,7 @@ implicit none integer, intent(in) :: ispin,sze_buff - integer(bit_kind), intent(in) :: det_1(N_int,2),det_2(N_int,2) + integer(bit_kind), intent(in) :: det_1(N_int),det_2(N_int) integer, intent(in) :: list_orb_reverse(mo_num) double precision, intent(in) :: c_1 double precision, intent(out) :: values(sze_buff) From 62f82b03c0aa62bf820f4dd5d2e919b396ad00bc Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Fri, 5 Jul 2019 10:31:02 +0200 Subject: [PATCH 45/59] OPENMP TWO-RDM --- src/tools/print_wf.irp.f | 2 +- src/two_body_rdm/orb_range_2_rdm_openmp.irp.f | 2 - .../orb_range_routines_openmp.irp.f | 84 ++++++++++--------- 3 files changed, 47 insertions(+), 41 deletions(-) diff --git a/src/tools/print_wf.irp.f b/src/tools/print_wf.irp.f index 01fc8948..3323b46e 100644 --- a/src/tools/print_wf.irp.f +++ b/src/tools/print_wf.irp.f @@ -51,7 +51,7 @@ subroutine routine if(degree == 0)then print*,'Reference determinant ' call i_H_j(psi_det(1,1,i),psi_det(1,1,i),N_int,h00) - else + else if(degree .le. 2)then call i_H_j(psi_det(1,1,i),psi_det(1,1,i),N_int,hii) call i_H_j(psi_det(1,1,1),psi_det(1,1,i),N_int,hij) delta_e = hii - h00 diff --git a/src/two_body_rdm/orb_range_2_rdm_openmp.irp.f b/src/two_body_rdm/orb_range_2_rdm_openmp.irp.f index 70bf0201..386e2a54 100644 --- a/src/two_body_rdm/orb_range_2_rdm_openmp.irp.f +++ b/src/two_body_rdm/orb_range_2_rdm_openmp.irp.f @@ -1,6 +1,4 @@ - - BEGIN_PROVIDER [double precision, state_av_act_two_rdm_openmp_alpha_alpha_mo, (n_act_orb,n_act_orb,n_act_orb,n_act_orb)] implicit none double precision, allocatable :: state_weights(:) diff --git a/src/two_body_rdm/orb_range_routines_openmp.irp.f b/src/two_body_rdm/orb_range_routines_openmp.irp.f index ba22e37d..97a8ce8a 100644 --- a/src/two_body_rdm/orb_range_routines_openmp.irp.f +++ b/src/two_body_rdm/orb_range_routines_openmp.irp.f @@ -76,6 +76,7 @@ end BEGIN_TEMPLATE subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,list_orb,state_weights,ispin,u_t,N_st,sze,istart,iend,ishift,istep) use bitmasks + use omp_lib implicit none BEGIN_DOC ! Computes the two rdm for the N_st vectors |u_t> @@ -92,6 +93,7 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis integer, intent(in) :: dim1,norb,list_orb(norb),ispin double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + integer(omp_lock_kind) :: lock_2rdm integer :: i,j,k,l integer :: k_a, k_b, l_a, l_b integer :: krow, kcol @@ -148,30 +150,31 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis do i=1,maxab idx0(i) = i enddo + call omp_init_lock(lock_2rdm) ! Prepare the array of all alpha single excitations ! ------------------------------------------------- PROVIDE N_int nthreads_davidson - !!$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) & - ! !$OMP SHARED(psi_bilinear_matrix_rows, N_det, & - ! !$OMP psi_bilinear_matrix_columns, & - ! !$OMP psi_det_alpha_unique, psi_det_beta_unique,& - ! !$OMP n_det_alpha_unique, n_det_beta_unique, N_int,& - ! !$OMP psi_bilinear_matrix_transp_rows, & - ! !$OMP psi_bilinear_matrix_transp_columns, & - ! !$OMP psi_bilinear_matrix_transp_order, N_st, & - ! !$OMP psi_bilinear_matrix_order_transp_reverse, & - ! !$OMP psi_bilinear_matrix_columns_loc, & - ! !$OMP psi_bilinear_matrix_transp_rows_loc, & - ! !$OMP istart, iend, istep, irp_here, v_t, s_t, & - ! !$OMP ishift, idx0, u_t, maxab, alpha_alpha,beta_beta,alpha_beta,spin_trace,ispin) & - ! !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,& - ! !$OMP lcol, lrow, l_a, l_b, & - ! !$OMP buffer, doubles, n_doubles, & - ! !$OMP tmp_det2, idx, l, kcol_prev, & - ! !$OMP singles_a, n_singles_a, singles_b, & - ! !$OMP n_singles_b, nkeys, keys, valus, c_average) + !$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) & + !$OMP SHARED(psi_bilinear_matrix_rows, N_det,lock_2rdm,& + !$OMP psi_bilinear_matrix_columns, & + !$OMP psi_det_alpha_unique, psi_det_beta_unique,& + !$OMP n_det_alpha_unique, n_det_beta_unique, N_int,& + !$OMP psi_bilinear_matrix_transp_rows, & + !$OMP psi_bilinear_matrix_transp_columns, & + !$OMP psi_bilinear_matrix_transp_order, N_st, & + !$OMP psi_bilinear_matrix_order_transp_reverse, & + !$OMP psi_bilinear_matrix_columns_loc, & + !$OMP psi_bilinear_matrix_transp_rows_loc,norb, & + !$OMP istart, iend, istep, irp_here,list_orb_reverse, n_states, state_weights, dim1, & + !$OMP ishift, idx0, u_t, maxab, alpha_alpha,beta_beta,alpha_beta,spin_trace,ispin,big_array,sze_buff,orb_bitmask) & + !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,c_1, c_2, & + !$OMP lcol, lrow, l_a, l_b, & + !$OMP buffer, doubles, n_doubles, & + !$OMP tmp_det2, idx, l, kcol_prev, & + !$OMP singles_a, n_singles_a, singles_b, & + !$OMP n_singles_b, nkeys, keys, values, c_average) ! Alpha/Beta double excitations ! ============================= @@ -189,7 +192,7 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis ASSERT (istart > 0) ASSERT (istep > 0) - !!$OMP DO SCHEDULE(dynamic,64) + !$OMP DO SCHEDULE(dynamic,64) do k_a=istart+ishift,iend,istep krow = psi_bilinear_matrix_rows(k_a) @@ -257,13 +260,13 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis if(alpha_beta)then ! only ONE contribution if (nkeys+1 .ge. size(values)) then - call update_keys_values(keys,values,size(values),nkeys,dim1,big_array) + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 endif else if (spin_trace)then ! TWO contributions if (nkeys+2 .ge. size(values)) then - call update_keys_values(keys,values,size(values),nkeys,dim1,big_array) + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 endif endif @@ -275,9 +278,9 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis enddo enddo - ! !$OMP END DO + !$OMP END DO - ! !$OMP DO SCHEDULE(dynamic,64) + !$OMP DO SCHEDULE(dynamic,64) do k_a=istart+ishift,iend,istep @@ -346,13 +349,13 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis if(alpha_beta.or.spin_trace.or.alpha_alpha)then ! increment the alpha/beta part for single excitations if (nkeys+ 2 * norb .ge. size(values)) then - call update_keys_values(keys,values,size(values),nkeys,dim1,big_array) + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 endif call orb_range_off_diag_single_to_two_rdm_ab_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) ! increment the alpha/alpha part for single excitations if (nkeys+4 * norb .ge. size(values)) then - call update_keys_values(keys,values,size(values),nkeys,dim1,big_array) + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 endif call orb_range_off_diag_single_to_two_rdm_aa_dm_buffer(tmp_det,tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) @@ -379,7 +382,7 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis c_average += c_1(l) * c_2(l) * state_weights(l) enddo if (nkeys+4 .ge. size(values)) then - call update_keys_values(keys,values,size(values),nkeys,dim1,big_array) + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 endif call orb_range_off_diag_double_to_two_rdm_aa_dm_buffer(tmp_det(1,1),psi_det_alpha_unique(1, lrow),c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) @@ -450,13 +453,13 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis if(alpha_beta.or.spin_trace.or.beta_beta)then ! increment the alpha/beta part for single excitations if (nkeys+2 * norb .ge. size(values)) then - call update_keys_values(keys,values,size(values),nkeys,dim1,big_array) + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 endif call orb_range_off_diag_single_to_two_rdm_ab_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) ! increment the beta /beta part for single excitations if (nkeys+4 * norb .ge. size(values)) then - call update_keys_values(keys,values,size(values),nkeys,dim1,big_array) + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 endif call orb_range_off_diag_single_to_two_rdm_bb_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) @@ -482,7 +485,7 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis c_average += c_1(l) * c_2(l) * state_weights(l) enddo if (nkeys+4 .ge. size(values)) then - call update_keys_values(keys,values,size(values),nkeys,dim1,big_array) + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 endif call orb_range_off_diag_double_to_two_rdm_bb_dm_buffer(tmp_det(1,2),psi_det_beta_unique(1, lcol),c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) @@ -517,16 +520,16 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis c_average += c_1(l) * c_1(l) * state_weights(l) enddo - call update_keys_values(keys,values,size(values),nkeys,dim1,big_array) + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 call orb_range_diag_to_all_two_rdm_dm_buffer(tmp_det,c_average,orb_bitmask,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) - call update_keys_values(keys,values,size(values),nkeys,dim1,big_array) + call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 end do - !!$OMP END DO + !$OMP END DO deallocate(buffer, singles_a, singles_b, doubles, idx, keys, values) - !!$OMP END PARALLEL + !$OMP END PARALLEL end @@ -541,14 +544,17 @@ end END_TEMPLATE -subroutine update_keys_values(keys,values,size_buff,nkeys,dim1,big_array) +subroutine update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) + use omp_lib implicit none - integer, intent(in) :: size_buff,nkeys,dim1 - integer, intent(in) :: keys(4,size_buff) - double precision, intent(in) :: values(size_buff) + integer, intent(in) :: nkeys,dim1 + integer, intent(in) :: keys(4,nkeys) + double precision, intent(in) :: values(nkeys) double precision, intent(inout) :: big_array(dim1,dim1,dim1,dim1) + integer(omp_lock_kind),intent(inout):: lock_2rdm integer :: i,h1,h2,p1,p2 + call omp_set_lock(lock_2rdm) do i = 1, nkeys h1 = keys(1,i) h2 = keys(2,i) @@ -556,5 +562,7 @@ subroutine update_keys_values(keys,values,size_buff,nkeys,dim1,big_array) p2 = keys(4,i) big_array(h1,h2,p1,p2) += values(i) enddo + call omp_unset_lock(lock_2rdm) end + From fd118fcc75ec98e7adb2ce784840e34192560f64 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Fri, 5 Jul 2019 13:05:11 +0200 Subject: [PATCH 46/59] beginning to compute perturbative rdm --- src/cipsi/NEED | 1 + src/cipsi/run_selection_slave.irp.f | 1 - src/cipsi/selection.irp.f | 166 +++++++++++++++++++++++++++- src/cipsi/update_2rdm.irp.f | 12 ++ 4 files changed, 178 insertions(+), 2 deletions(-) create mode 100644 src/cipsi/update_2rdm.irp.f diff --git a/src/cipsi/NEED b/src/cipsi/NEED index 0cab61d0..c9dc92c0 100644 --- a/src/cipsi/NEED +++ b/src/cipsi/NEED @@ -3,3 +3,4 @@ zmq mpi davidson_undressed iterations +two_body_rdm diff --git a/src/cipsi/run_selection_slave.irp.f b/src/cipsi/run_selection_slave.irp.f index c1542445..a80a9372 100644 --- a/src/cipsi/run_selection_slave.irp.f +++ b/src/cipsi/run_selection_slave.irp.f @@ -61,7 +61,6 @@ subroutine run_selection_slave(thread,iproc,energy) ! Only first time bsize = min(N, (elec_alpha_num * (mo_num-elec_alpha_num))**2) call create_selection_buffer(bsize, bsize*2, buf) -! call create_selection_buffer(N, N*2, buf2) buffer_ready = .True. else ASSERT (N == buf%N) diff --git a/src/cipsi/selection.irp.f b/src/cipsi/selection.irp.f index 062b44bf..72f18dd3 100644 --- a/src/cipsi/selection.irp.f +++ b/src/cipsi/selection.irp.f @@ -1,5 +1,10 @@ use bitmasks +BEGIN_PROVIDER [logical , pert_2rdm ] + implicit none + pert_2rdm = .False. +END_PROVIDER + BEGIN_PROVIDER [ double precision, pt2_match_weight, (N_states) ] implicit none BEGIN_DOC @@ -248,6 +253,7 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d integer,allocatable :: tmp_array(:) integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :) logical, allocatable :: banned(:,:,:), bannedOrb(:,:) + double precision, allocatable :: coef_fullminilist(:,:) double precision, allocatable :: mat(:,:,:) @@ -546,6 +552,12 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d allocate (fullminilist (N_int, 2, fullinteresting(0)), & minilist (N_int, 2, interesting(0)) ) + if(pert_2rdm)then + allocate(coef_fullminilist(fullinteresting(0),N_states)) + do i=1,fullinteresting(0) + coef_fullminilist(i,:) = psi_coef_sorted(fullinteresting(i),:) + enddo + endif do i=1,fullinteresting(0) fullminilist(1:N_int,1:2,i) = psi_det_sorted(1:N_int,1:2,fullinteresting(i)) enddo @@ -597,12 +609,19 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d call splash_pq(mask, sp, minilist, i_generator, interesting(0), bannedOrb, banned, mat, interesting) - call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, variance, norm, mat, buf) + if(.not.pert_2rdm)then + call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, variance, norm, mat, buf) + else + call fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, variance, norm, mat, buf,fullminilist, coef_fullminilist, fullinteresting(0)) + endif end if enddo if(s1 /= s2) monoBdo = .false. enddo deallocate(fullminilist,minilist) + if(pert_2rdm)then + deallocate(coef_fullminilist) + endif enddo enddo deallocate(preinteresting, prefullinteresting, interesting, fullinteresting) @@ -633,6 +652,10 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d double precision :: E_shift logical, external :: detEq + double precision, allocatable :: values(:) + integer, allocatable :: keys(:,;) + integer, :: nkeys + if(sp == 3) then s1 = 1 @@ -746,6 +769,147 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d end +subroutine fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, variance, norm, mat, buf, psi_det_connection, psi_coef_connection, n_det_connection) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: n_det_connection + double precision, intent(in) :: psi_coef_connection(n_det_connection,N_states) + integer(bit_kind), intent(in) :: psi_det_connection(N_int,2,n_det_connection) + integer, intent(in) :: i_generator, sp, h1, h2 + double precision, intent(in) :: mat(N_states, mo_num, mo_num) + logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num) + double precision, intent(in) :: fock_diag_tmp(mo_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + double precision, intent(inout) :: variance(N_states) + double precision, intent(inout) :: norm(N_states) + type(selection_buffer), intent(inout) :: buf + logical :: ok + integer :: s1, s2, p1, p2, ib, j, istate + integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) + double precision :: e_pert, delta_E, val, Hii, sum_e_pert, tmp, alpha_h_psi, coef(N_states) + double precision, external :: diag_H_mat_elem_fock + double precision :: E_shift + + logical, external :: detEq + double precision, allocatable :: values(:) + integer, allocatable :: keys(:,;) + integer, :: nkeys + integer :: sze_buffer + sze_buffer = 5 * mo_num ** 2 + allocate(keys(4,sze_buffer),values(sze_buffer)) + nkeys = 0 + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) + E_shift = 0.d0 + + if (h0_type == 'SOP') then + j = det_to_occ_pattern(i_generator) + E_shift = psi_det_Hii(i_generator) - psi_occ_pattern_Hii(j) + endif + + do p1=1,mo_num + if(bannedOrb(p1, s1)) cycle + ib = 1 + if(sp /= 3) ib = p1+1 + + do p2=ib,mo_num + +! ----- +! /!\ Generating only single excited determinants doesn't work because a +! determinant generated by a single excitation may be doubly excited wrt +! to a determinant of the future. In that case, the determinant will be +! detected as already generated when generating in the future with a +! double excitation. +! +! if (.not.do_singles) then +! if ((h1 == p1) .or. (h2 == p2)) then +! cycle +! endif +! endif +! +! if (.not.do_doubles) then +! if ((h1 /= p1).and.(h2 /= p2)) then +! cycle +! endif +! endif +! ----- + + if(bannedOrb(p2, s2)) cycle + if(banned(p1,p2)) cycle + + + if( sum(abs(mat(1:N_states, p1, p2))) == 0d0) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + + if (do_only_cas) then + integer, external :: number_of_holes, number_of_particles + if (number_of_particles(det)>0) then + cycle + endif + if (number_of_holes(det)>0) then + cycle + endif + endif + + if (do_ddci) then + logical, external :: is_a_two_holes_two_particles + if (is_a_two_holes_two_particles(det)) then + cycle + endif + endif + + if (do_only_1h1p) then + logical, external :: is_a_1h1p + if (.not.is_a_1h1p(det)) cycle + endif + + + Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) + + sum_e_pert = 0d0 + + do istate=1,N_states + delta_E = E0(istate) - Hii + E_shift + alpha_h_psi = mat(istate, p1, p2) + val = alpha_h_psi + alpha_h_psi + tmp = dsqrt(delta_E * delta_E + val * val) + if (delta_E < 0.d0) then + tmp = -tmp + endif + e_pert = 0.5d0 * (tmp - delta_E) + coef(istate) = e_pert / alpha_h_psi + pt2(istate) = pt2(istate) + e_pert + variance(istate) = variance(istate) + alpha_h_psi * alpha_h_psi + norm(istate) = norm(istate) + coef * coef + + if (weight_selection /= 5) then + ! Energy selection + sum_e_pert = sum_e_pert + e_pert * selection_weight(istate) + else + ! Variance selection + sum_e_pert = sum_e_pert - alpha_h_psi * alpha_h_psi * selection_weight(istate) + endif + end do + + call give_2rdm_pert_contrib(det,coef,psi_det_connection,psi_coef_connection,n_det_connection,nkeys,keys,values,sze_buff) + + if(sum_e_pert <= buf%mini) then + call add_to_selection_buffer(buf, det, sum_e_pert) + end if + end do + end do +end + + subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting) use bitmasks implicit none diff --git a/src/cipsi/update_2rdm.irp.f b/src/cipsi/update_2rdm.irp.f new file mode 100644 index 00000000..7595204f --- /dev/null +++ b/src/cipsi/update_2rdm.irp.f @@ -0,0 +1,12 @@ +use bitmasks + +subroutine give_2rdm_pert_contrib(det,coef,psi_det_connection,psi_coef_connection,n_det_connection,nkeys,keys,values,sze_buff) + implicit none + integer, intent(in) :: n_det_connection,nkeys,sze_buff + double precision, intent(in) :: coef(N_states) + integer(bit_kind), intent(in) :: det(N_int,2) + integer(bit_kind), intent(in) :: psi_det_connection(N_int,2,n_det_connection) + integer, intent(in) :: keys(4,sze_buff) + double precision, intent(in) :: values(sze_buff) + +end From 25b20651bac9bcb273ae36dcedfdc0da3c8026bc Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Fri, 5 Jul 2019 13:36:53 +0200 Subject: [PATCH 47/59] fixed compilation bugs --- src/cipsi/selection.irp.f | 16 ++++++++-------- src/cipsi/update_2rdm.irp.f | 7 ++++--- 2 files changed, 12 insertions(+), 11 deletions(-) diff --git a/src/cipsi/selection.irp.f b/src/cipsi/selection.irp.f index 72f18dd3..19e53dcc 100644 --- a/src/cipsi/selection.irp.f +++ b/src/cipsi/selection.irp.f @@ -653,8 +653,8 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d logical, external :: detEq double precision, allocatable :: values(:) - integer, allocatable :: keys(:,;) - integer, :: nkeys + integer, allocatable :: keys(:,:) + integer :: nkeys if(sp == 3) then @@ -795,11 +795,11 @@ subroutine fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fo logical, external :: detEq double precision, allocatable :: values(:) - integer, allocatable :: keys(:,;) - integer, :: nkeys - integer :: sze_buffer - sze_buffer = 5 * mo_num ** 2 - allocate(keys(4,sze_buffer),values(sze_buffer)) + integer, allocatable :: keys(:,:) + integer :: nkeys + integer :: sze_buff + sze_buff = 5 * mo_num ** 2 + allocate(keys(4,sze_buff),values(sze_buff)) nkeys = 0 if(sp == 3) then s1 = 1 @@ -889,7 +889,7 @@ subroutine fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fo coef(istate) = e_pert / alpha_h_psi pt2(istate) = pt2(istate) + e_pert variance(istate) = variance(istate) + alpha_h_psi * alpha_h_psi - norm(istate) = norm(istate) + coef * coef + norm(istate) = norm(istate) + coef(istate) * coef(istate) if (weight_selection /= 5) then ! Energy selection diff --git a/src/cipsi/update_2rdm.irp.f b/src/cipsi/update_2rdm.irp.f index 7595204f..07a746d4 100644 --- a/src/cipsi/update_2rdm.irp.f +++ b/src/cipsi/update_2rdm.irp.f @@ -2,11 +2,12 @@ use bitmasks subroutine give_2rdm_pert_contrib(det,coef,psi_det_connection,psi_coef_connection,n_det_connection,nkeys,keys,values,sze_buff) implicit none - integer, intent(in) :: n_det_connection,nkeys,sze_buff + integer, intent(in) :: n_det_connection,nkeys double precision, intent(in) :: coef(N_states) integer(bit_kind), intent(in) :: det(N_int,2) integer(bit_kind), intent(in) :: psi_det_connection(N_int,2,n_det_connection) - integer, intent(in) :: keys(4,sze_buff) - double precision, intent(in) :: values(sze_buff) + double precision, intent(in) :: psi_coef_connection(n_det_connection, N_states) + integer, intent(inout) :: keys(4,sze_buff),sze_buff + double precision, intent(inout) :: values(sze_buff) end From b1c7c121b21da7ece830289801931eed1d7f36cf Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Fri, 5 Jul 2019 15:39:27 +0200 Subject: [PATCH 48/59] working on pert rdms --- src/cipsi/pert_rdm_providers.irp.f | 166 ++++++++++++++++++ src/cipsi/selection.irp.f | 148 +--------------- src/cipsi/update_2rdm.irp.f | 52 ++++++ .../orb_range_routines_openmp.irp.f | 14 +- 4 files changed, 226 insertions(+), 154 deletions(-) create mode 100644 src/cipsi/pert_rdm_providers.irp.f diff --git a/src/cipsi/pert_rdm_providers.irp.f b/src/cipsi/pert_rdm_providers.irp.f new file mode 100644 index 00000000..ad5355a2 --- /dev/null +++ b/src/cipsi/pert_rdm_providers.irp.f @@ -0,0 +1,166 @@ + +use bitmasks + +BEGIN_PROVIDER [logical , pert_2rdm ] + implicit none + pert_2rdm = .False. +END_PROVIDER + +BEGIN_PROVIDER [integer, n_orb_pert_rdm] + implicit none + n_orb_pert_rdm = n_act_orb +END_PROVIDER + +BEGIN_PROVIDER [integer, list_orb_reverse_pert_rdm, (mo_num)] + implicit none + list_orb_reverse_pert_rdm = list_act_reverse + +END_PROVIDER + +BEGIN_PROVIDER [integer, list_orb_pert_rdm, (n_orb_pert_rdm)] + implicit none + list_orb_pert_rdm = list_act + +END_PROVIDER + +subroutine fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, variance, norm, mat, buf, psi_det_connection, psi_coef_connection, n_det_connection) + use bitmasks + use selection_types + implicit none + + integer, intent(in) :: n_det_connection + double precision, intent(in) :: psi_coef_connection(n_det_connection,N_states) + integer(bit_kind), intent(in) :: psi_det_connection(N_int,2,n_det_connection) + integer, intent(in) :: i_generator, sp, h1, h2 + double precision, intent(in) :: mat(N_states, mo_num, mo_num) + logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num) + double precision, intent(in) :: fock_diag_tmp(mo_num) + double precision, intent(in) :: E0(N_states) + double precision, intent(inout) :: pt2(N_states) + double precision, intent(inout) :: variance(N_states) + double precision, intent(inout) :: norm(N_states) + type(selection_buffer), intent(inout) :: buf + logical :: ok + integer :: s1, s2, p1, p2, ib, j, istate + integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) + double precision :: e_pert, delta_E, val, Hii, sum_e_pert, tmp, alpha_h_psi, coef(N_states) + double precision, external :: diag_H_mat_elem_fock + double precision :: E_shift + + logical, external :: detEq + double precision, allocatable :: values(:) + integer, allocatable :: keys(:,:) + integer :: nkeys + integer :: sze_buff + sze_buff = 5 * mo_num ** 2 + allocate(keys(4,sze_buff),values(sze_buff)) + nkeys = 0 + if(sp == 3) then + s1 = 1 + s2 = 2 + else + s1 = sp + s2 = sp + end if + call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) + E_shift = 0.d0 + + if (h0_type == 'SOP') then + j = det_to_occ_pattern(i_generator) + E_shift = psi_det_Hii(i_generator) - psi_occ_pattern_Hii(j) + endif + + do p1=1,mo_num + if(bannedOrb(p1, s1)) cycle + ib = 1 + if(sp /= 3) ib = p1+1 + + do p2=ib,mo_num + +! ----- +! /!\ Generating only single excited determinants doesn't work because a +! determinant generated by a single excitation may be doubly excited wrt +! to a determinant of the future. In that case, the determinant will be +! detected as already generated when generating in the future with a +! double excitation. +! +! if (.not.do_singles) then +! if ((h1 == p1) .or. (h2 == p2)) then +! cycle +! endif +! endif +! +! if (.not.do_doubles) then +! if ((h1 /= p1).and.(h2 /= p2)) then +! cycle +! endif +! endif +! ----- + + if(bannedOrb(p2, s2)) cycle + if(banned(p1,p2)) cycle + + + if( sum(abs(mat(1:N_states, p1, p2))) == 0d0) cycle + call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) + + if (do_only_cas) then + integer, external :: number_of_holes, number_of_particles + if (number_of_particles(det)>0) then + cycle + endif + if (number_of_holes(det)>0) then + cycle + endif + endif + + if (do_ddci) then + logical, external :: is_a_two_holes_two_particles + if (is_a_two_holes_two_particles(det)) then + cycle + endif + endif + + if (do_only_1h1p) then + logical, external :: is_a_1h1p + if (.not.is_a_1h1p(det)) cycle + endif + + + Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) + + sum_e_pert = 0d0 + + do istate=1,N_states + delta_E = E0(istate) - Hii + E_shift + alpha_h_psi = mat(istate, p1, p2) + val = alpha_h_psi + alpha_h_psi + tmp = dsqrt(delta_E * delta_E + val * val) + if (delta_E < 0.d0) then + tmp = -tmp + endif + e_pert = 0.5d0 * (tmp - delta_E) + coef(istate) = e_pert / alpha_h_psi + pt2(istate) = pt2(istate) + e_pert + variance(istate) = variance(istate) + alpha_h_psi * alpha_h_psi + norm(istate) = norm(istate) + coef(istate) * coef(istate) + + if (weight_selection /= 5) then + ! Energy selection + sum_e_pert = sum_e_pert + e_pert * selection_weight(istate) + else + ! Variance selection + sum_e_pert = sum_e_pert - alpha_h_psi * alpha_h_psi * selection_weight(istate) + endif + end do + + call give_2rdm_pert_contrib(det,coef,psi_det_connection,psi_coef_connection,n_det_connection,nkeys,keys,values,sze_buff) + + if(sum_e_pert <= buf%mini) then + call add_to_selection_buffer(buf, det, sum_e_pert) + end if + end do + end do +end + + diff --git a/src/cipsi/selection.irp.f b/src/cipsi/selection.irp.f index 19e53dcc..71442538 100644 --- a/src/cipsi/selection.irp.f +++ b/src/cipsi/selection.irp.f @@ -1,9 +1,5 @@ -use bitmasks -BEGIN_PROVIDER [logical , pert_2rdm ] - implicit none - pert_2rdm = .False. -END_PROVIDER +use bitmasks BEGIN_PROVIDER [ double precision, pt2_match_weight, (N_states) ] implicit none @@ -768,148 +764,6 @@ subroutine fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_d end do end - -subroutine fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, variance, norm, mat, buf, psi_det_connection, psi_coef_connection, n_det_connection) - use bitmasks - use selection_types - implicit none - - integer, intent(in) :: n_det_connection - double precision, intent(in) :: psi_coef_connection(n_det_connection,N_states) - integer(bit_kind), intent(in) :: psi_det_connection(N_int,2,n_det_connection) - integer, intent(in) :: i_generator, sp, h1, h2 - double precision, intent(in) :: mat(N_states, mo_num, mo_num) - logical, intent(in) :: bannedOrb(mo_num, 2), banned(mo_num, mo_num) - double precision, intent(in) :: fock_diag_tmp(mo_num) - double precision, intent(in) :: E0(N_states) - double precision, intent(inout) :: pt2(N_states) - double precision, intent(inout) :: variance(N_states) - double precision, intent(inout) :: norm(N_states) - type(selection_buffer), intent(inout) :: buf - logical :: ok - integer :: s1, s2, p1, p2, ib, j, istate - integer(bit_kind) :: mask(N_int, 2), det(N_int, 2) - double precision :: e_pert, delta_E, val, Hii, sum_e_pert, tmp, alpha_h_psi, coef(N_states) - double precision, external :: diag_H_mat_elem_fock - double precision :: E_shift - - logical, external :: detEq - double precision, allocatable :: values(:) - integer, allocatable :: keys(:,:) - integer :: nkeys - integer :: sze_buff - sze_buff = 5 * mo_num ** 2 - allocate(keys(4,sze_buff),values(sze_buff)) - nkeys = 0 - if(sp == 3) then - s1 = 1 - s2 = 2 - else - s1 = sp - s2 = sp - end if - call apply_holes(psi_det_generators(1,1,i_generator), s1, h1, s2, h2, mask, ok, N_int) - E_shift = 0.d0 - - if (h0_type == 'SOP') then - j = det_to_occ_pattern(i_generator) - E_shift = psi_det_Hii(i_generator) - psi_occ_pattern_Hii(j) - endif - - do p1=1,mo_num - if(bannedOrb(p1, s1)) cycle - ib = 1 - if(sp /= 3) ib = p1+1 - - do p2=ib,mo_num - -! ----- -! /!\ Generating only single excited determinants doesn't work because a -! determinant generated by a single excitation may be doubly excited wrt -! to a determinant of the future. In that case, the determinant will be -! detected as already generated when generating in the future with a -! double excitation. -! -! if (.not.do_singles) then -! if ((h1 == p1) .or. (h2 == p2)) then -! cycle -! endif -! endif -! -! if (.not.do_doubles) then -! if ((h1 /= p1).and.(h2 /= p2)) then -! cycle -! endif -! endif -! ----- - - if(bannedOrb(p2, s2)) cycle - if(banned(p1,p2)) cycle - - - if( sum(abs(mat(1:N_states, p1, p2))) == 0d0) cycle - call apply_particles(mask, s1, p1, s2, p2, det, ok, N_int) - - if (do_only_cas) then - integer, external :: number_of_holes, number_of_particles - if (number_of_particles(det)>0) then - cycle - endif - if (number_of_holes(det)>0) then - cycle - endif - endif - - if (do_ddci) then - logical, external :: is_a_two_holes_two_particles - if (is_a_two_holes_two_particles(det)) then - cycle - endif - endif - - if (do_only_1h1p) then - logical, external :: is_a_1h1p - if (.not.is_a_1h1p(det)) cycle - endif - - - Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) - - sum_e_pert = 0d0 - - do istate=1,N_states - delta_E = E0(istate) - Hii + E_shift - alpha_h_psi = mat(istate, p1, p2) - val = alpha_h_psi + alpha_h_psi - tmp = dsqrt(delta_E * delta_E + val * val) - if (delta_E < 0.d0) then - tmp = -tmp - endif - e_pert = 0.5d0 * (tmp - delta_E) - coef(istate) = e_pert / alpha_h_psi - pt2(istate) = pt2(istate) + e_pert - variance(istate) = variance(istate) + alpha_h_psi * alpha_h_psi - norm(istate) = norm(istate) + coef(istate) * coef(istate) - - if (weight_selection /= 5) then - ! Energy selection - sum_e_pert = sum_e_pert + e_pert * selection_weight(istate) - else - ! Variance selection - sum_e_pert = sum_e_pert - alpha_h_psi * alpha_h_psi * selection_weight(istate) - endif - end do - - call give_2rdm_pert_contrib(det,coef,psi_det_connection,psi_coef_connection,n_det_connection,nkeys,keys,values,sze_buff) - - if(sum_e_pert <= buf%mini) then - call add_to_selection_buffer(buf, det, sum_e_pert) - end if - end do - end do -end - - subroutine splash_pq(mask, sp, det, i_gen, N_sel, bannedOrb, banned, mat, interesting) use bitmasks implicit none diff --git a/src/cipsi/update_2rdm.irp.f b/src/cipsi/update_2rdm.irp.f index 07a746d4..3d6409af 100644 --- a/src/cipsi/update_2rdm.irp.f +++ b/src/cipsi/update_2rdm.irp.f @@ -9,5 +9,57 @@ subroutine give_2rdm_pert_contrib(det,coef,psi_det_connection,psi_coef_connectio double precision, intent(in) :: psi_coef_connection(n_det_connection, N_states) integer, intent(inout) :: keys(4,sze_buff),sze_buff double precision, intent(inout) :: values(sze_buff) + integer :: i + integer :: exc(0:2,2,2) + integer :: degree + double precision :: phase, contrib + do i = 1, n_det_connection + call get_excitation(det,psi_det_connection(1,1,i),exc,degree,phase,N_int) + if(degree.gt.2)cycle + contrib = 0.d0 + do j = 1, N_states + contrib += state_average_weight(j) * psi_coef_connection(i,j) * phase * coef(j) + enddo + ! case of single excitations + if(degree == 1)then + if (nkeys+ 2 * elec_alpha_num .ge. sze_buff)then + call update_rdms(nkeys,keys,values,sze_buff) + nkeys = 0 + endif + call update_buffer_single_exc_rdm(det,psi_det_connection(1,1,i),exc,phase,contrib,nkeys,keys,values,sze_buff) + else + ! case of double excitations + if (nkeys+ 4 .ge. sze_buff)then + call update_rdms(nkeys,keys,values,sze_buff) + nkeys = 0 + endif + call update_buffer_double_exc_rdm(exc,phase,contrib,nkeys,keys,values,sze_buff) + endif + enddo + +end + +subroutine update_buffer_single_exc_rdm(det1,det2,exc,phase,contrib,nkeys,keys,values,sze_buff) + implicit none + integer, intent(in) :: nkeys,sze_buff + integer(bit_kind), intent(in) :: det1(N_int,2) + integer(bit_kind), intent(in) :: det2(N_int,2) + integer,intent(in) :: exc(0:2,2,2) + double precision,intent(in) :: phase, contrib + integer, intent(inout) :: nkeys, keys(4,sze_buff) + double precision, intent(inout):: values(sze_buff) + + + +end + +subroutine update_buffer_double_exc_rdm(exc,phase,contrib,nkeys,keys,values,sze_buff) + implicit none + integer, intent(in) :: nkeys,sze_buff + integer,intent(in) :: exc(0:2,2,2) + double precision,intent(in) :: phase, contrib + integer, intent(inout) :: nkeys, keys(4,sze_buff) + double precision, intent(inout):: values(sze_buff) + end diff --git a/src/two_body_rdm/orb_range_routines_openmp.irp.f b/src/two_body_rdm/orb_range_routines_openmp.irp.f index 97a8ce8a..269f789c 100644 --- a/src/two_body_rdm/orb_range_routines_openmp.irp.f +++ b/src/two_body_rdm/orb_range_routines_openmp.irp.f @@ -166,7 +166,7 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis !$OMP psi_bilinear_matrix_transp_order, N_st, & !$OMP psi_bilinear_matrix_order_transp_reverse, & !$OMP psi_bilinear_matrix_columns_loc, & - !$OMP psi_bilinear_matrix_transp_rows_loc,norb, & + !$OMP psi_bilinear_matrix_transp_rows_loc, & !$OMP istart, iend, istep, irp_here,list_orb_reverse, n_states, state_weights, dim1, & !$OMP ishift, idx0, u_t, maxab, alpha_alpha,beta_beta,alpha_beta,spin_trace,ispin,big_array,sze_buff,orb_bitmask) & !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,c_1, c_2, & @@ -348,13 +348,13 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis enddo if(alpha_beta.or.spin_trace.or.alpha_alpha)then ! increment the alpha/beta part for single excitations - if (nkeys+ 2 * norb .ge. size(values)) then + if (nkeys+ 2 * elec_alpha_num .ge. sze_buff) then call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 endif call orb_range_off_diag_single_to_two_rdm_ab_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) ! increment the alpha/alpha part for single excitations - if (nkeys+4 * norb .ge. size(values)) then + if (nkeys+4 * elec_alpha_num .ge. sze_buff ) then call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 endif @@ -381,7 +381,7 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis c_2(l) = u_t(l,k_a) c_average += c_1(l) * c_2(l) * state_weights(l) enddo - if (nkeys+4 .ge. size(values)) then + if (nkeys+4 .ge. sze_buff) then call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 endif @@ -452,13 +452,13 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis enddo if(alpha_beta.or.spin_trace.or.beta_beta)then ! increment the alpha/beta part for single excitations - if (nkeys+2 * norb .ge. size(values)) then + if (nkeys+2 * elec_alpha_num .ge. sze_buff ) then call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 endif call orb_range_off_diag_single_to_two_rdm_ab_dm_buffer(tmp_det, tmp_det2,c_average,list_orb_reverse,ispin,sze_buff,nkeys,keys,values) ! increment the beta /beta part for single excitations - if (nkeys+4 * norb .ge. size(values)) then + if (nkeys+4 * elec_alpha_num .ge. sze_buff) then call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 endif @@ -484,7 +484,7 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis c_2(l) = u_t(l,k_a) c_average += c_1(l) * c_2(l) * state_weights(l) enddo - if (nkeys+4 .ge. size(values)) then + if (nkeys+4 .ge. sze_buff) then call update_keys_values(keys,values,nkeys,dim1,big_array,lock_2rdm) nkeys = 0 endif From 53eb7f553171680385f484f91260147933ddf9f5 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Fri, 5 Jul 2019 15:48:31 +0200 Subject: [PATCH 49/59] compiles --- src/cipsi/pert_rdm_providers.irp.f | 6 +++++ src/cipsi/update_2rdm.irp.f | 25 +++++++++++++++---- .../orb_range_routines_openmp.irp.f | 4 +-- 3 files changed, 28 insertions(+), 7 deletions(-) diff --git a/src/cipsi/pert_rdm_providers.irp.f b/src/cipsi/pert_rdm_providers.irp.f index ad5355a2..9cf8fba7 100644 --- a/src/cipsi/pert_rdm_providers.irp.f +++ b/src/cipsi/pert_rdm_providers.irp.f @@ -23,6 +23,12 @@ BEGIN_PROVIDER [integer, list_orb_pert_rdm, (n_orb_pert_rdm)] END_PROVIDER +BEGIN_PROVIDER [double precision, pert_2rdm_provider, (n_orb_pert_rdm,n_orb_pert_rdm,n_orb_pert_rdm,n_orb_pert_rdm)] + implicit none + pert_2rdm_provider = 0.d0 + +END_PROVIDER + subroutine fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, variance, norm, mat, buf, psi_det_connection, psi_coef_connection, n_det_connection) use bitmasks use selection_types diff --git a/src/cipsi/update_2rdm.irp.f b/src/cipsi/update_2rdm.irp.f index 3d6409af..7ae42ea8 100644 --- a/src/cipsi/update_2rdm.irp.f +++ b/src/cipsi/update_2rdm.irp.f @@ -2,14 +2,14 @@ use bitmasks subroutine give_2rdm_pert_contrib(det,coef,psi_det_connection,psi_coef_connection,n_det_connection,nkeys,keys,values,sze_buff) implicit none - integer, intent(in) :: n_det_connection,nkeys + integer, intent(in) :: n_det_connection,sze_buff double precision, intent(in) :: coef(N_states) integer(bit_kind), intent(in) :: det(N_int,2) integer(bit_kind), intent(in) :: psi_det_connection(N_int,2,n_det_connection) double precision, intent(in) :: psi_coef_connection(n_det_connection, N_states) - integer, intent(inout) :: keys(4,sze_buff),sze_buff + integer, intent(inout) :: keys(4,sze_buff),nkeys double precision, intent(inout) :: values(sze_buff) - integer :: i + integer :: i,j integer :: exc(0:2,2,2) integer :: degree double precision :: phase, contrib @@ -41,7 +41,7 @@ end subroutine update_buffer_single_exc_rdm(det1,det2,exc,phase,contrib,nkeys,keys,values,sze_buff) implicit none - integer, intent(in) :: nkeys,sze_buff + integer, intent(in) :: sze_buff integer(bit_kind), intent(in) :: det1(N_int,2) integer(bit_kind), intent(in) :: det2(N_int,2) integer,intent(in) :: exc(0:2,2,2) @@ -55,7 +55,7 @@ end subroutine update_buffer_double_exc_rdm(exc,phase,contrib,nkeys,keys,values,sze_buff) implicit none - integer, intent(in) :: nkeys,sze_buff + integer, intent(in) :: sze_buff integer,intent(in) :: exc(0:2,2,2) double precision,intent(in) :: phase, contrib integer, intent(inout) :: nkeys, keys(4,sze_buff) @@ -63,3 +63,18 @@ subroutine update_buffer_double_exc_rdm(exc,phase,contrib,nkeys,keys,values,sze_ end + + +subroutine update_rdms(nkeys,keys,values,sze_buff) + implicit none + integer, intent(in) :: nkeys, keys(4,sze_buff),sze_buff + double precision, intent(in) :: values(sze_buff) + integer :: i,h1,h2,p1,p2 + do i = 1, nkeys + h1 = keys(1,i) + h2 = keys(2,i) + p1 = keys(3,i) + p2 = keys(4,i) + pert_2rdm_provider(h1,h2,p1,p2) += values(i) + enddo +end diff --git a/src/two_body_rdm/orb_range_routines_openmp.irp.f b/src/two_body_rdm/orb_range_routines_openmp.irp.f index 269f789c..b6e59540 100644 --- a/src/two_body_rdm/orb_range_routines_openmp.irp.f +++ b/src/two_body_rdm/orb_range_routines_openmp.irp.f @@ -155,7 +155,7 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis ! Prepare the array of all alpha single excitations ! ------------------------------------------------- - PROVIDE N_int nthreads_davidson + PROVIDE N_int nthreads_davidson elec_alpha_num !$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(nthreads_davidson) & !$OMP SHARED(psi_bilinear_matrix_rows, N_det,lock_2rdm,& !$OMP psi_bilinear_matrix_columns, & @@ -166,7 +166,7 @@ subroutine orb_range_two_rdm_state_av_openmp_work_$N_int(big_array,dim1,norb,lis !$OMP psi_bilinear_matrix_transp_order, N_st, & !$OMP psi_bilinear_matrix_order_transp_reverse, & !$OMP psi_bilinear_matrix_columns_loc, & - !$OMP psi_bilinear_matrix_transp_rows_loc, & + !$OMP psi_bilinear_matrix_transp_rows_loc,elec_alpha_num, & !$OMP istart, iend, istep, irp_here,list_orb_reverse, n_states, state_weights, dim1, & !$OMP ishift, idx0, u_t, maxab, alpha_alpha,beta_beta,alpha_beta,spin_trace,ispin,big_array,sze_buff,orb_bitmask) & !$OMP PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,c_1, c_2, & From 03367381097efc90c32f73ac244ee1c2570b618d Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 5 Jul 2019 18:50:22 +0200 Subject: [PATCH 50/59] Working on fast integrals --- src/casscf/bavard.irp.f | 4 +- src/casscf/casscf.irp.f | 11 +- src/casscf/get_energy.irp.f | 26 +-- src/casscf/natorb.irp.f | 47 +++--- src/mo_two_e_ints/four_idx_novvvv.irp.f | 202 ++++++++++++++++++++++++ src/mo_two_e_ints/mo_bi_integrals.irp.f | 134 +++------------- 6 files changed, 260 insertions(+), 164 deletions(-) create mode 100644 src/mo_two_e_ints/four_idx_novvvv.irp.f diff --git a/src/casscf/bavard.irp.f b/src/casscf/bavard.irp.f index a9797712..402e67ec 100644 --- a/src/casscf/bavard.irp.f +++ b/src/casscf/bavard.irp.f @@ -1,6 +1,6 @@ ! -*- F90 -*- BEGIN_PROVIDER [logical, bavard] - bavard=.true. -! bavard=.false. +! bavard=.true. + bavard=.false. END_PROVIDER diff --git a/src/casscf/casscf.irp.f b/src/casscf/casscf.irp.f index 1b77cf43..3fc6fd8e 100644 --- a/src/casscf/casscf.irp.f +++ b/src/casscf/casscf.irp.f @@ -4,8 +4,10 @@ program casscf ! TODO : Put the documentation of the program here END_DOC no_vvvv_integrals = .True. + no_ivvv_integrals = .True. + no_vvv_integrals = .True. pt2_max = 0.02 - SOFT_TOUCH no_vvvv_integrals pt2_max + SOFT_TOUCH no_vvvv_integrals no_vvv_integrals pt2_max call run end @@ -32,17 +34,16 @@ subroutine run converged = dabs(energy_improvement) < thresh_scf pt2_max = dabs(energy_improvement / pt2_relative_error) - call update_integrals mo_coef = NewOrbs call save_mos - call map_deinit(mo_integrals_map) iteration += 1 N_det = N_det/2 psi_det = psi_det_sorted psi_coef = psi_coef_sorted read_wf = .True. - FREE mo_integrals_map mo_two_e_integrals_in_map - SOFT_TOUCH mo_coef N_det pt2_max psi_det psi_coef + call map_deinit(mo_integrals_map) + FREE mo_two_e_integrals_in_map mo_integrals_map + SOFT_TOUCH mo_coef N_det pt2_max psi_det psi_coef enddo diff --git a/src/casscf/get_energy.irp.f b/src/casscf/get_energy.irp.f index 0a5cfb49..772af92a 100644 --- a/src/casscf/get_energy.irp.f +++ b/src/casscf/get_energy.irp.f @@ -5,32 +5,12 @@ program print_2rdm ! ! useful to test the active part of the spin trace 2 rdms END_DOC + no_vvvv_integrals = .True. read_wf = .True. - touch read_wf + touch read_wf no_vvvv_integrals call routine end subroutine routine - integer :: i,j,k,l - integer :: ii,jj,kk,ll - double precision :: accu(4),twodm,thr,act_twodm2,integral,get_two_e_integral - thr = 1.d-10 - - - accu = 0.d0 - do ll = 1, n_act_orb - l = list_act(ll) - do kk = 1, n_act_orb - k = list_act(kk) - do jj = 1, n_act_orb - j = list_act(jj) - do ii = 1, n_act_orb - i = list_act(ii) - integral = get_two_e_integral(i,j,k,l,mo_integrals_map) - accu(1) += act_two_rdm_spin_trace_mo(ii,jj,kk,ll) * integral - enddo - enddo - enddo - enddo - print*,'accu = ',accu(1) + print *, psi_energy_with_nucl_rep end diff --git a/src/casscf/natorb.irp.f b/src/casscf/natorb.irp.f index c84b4862..9ce90304 100644 --- a/src/casscf/natorb.irp.f +++ b/src/casscf/natorb.irp.f @@ -196,33 +196,36 @@ BEGIN_PROVIDER [real*8, one_ints_no, (mo_num,mo_num)] END_PROVIDER +BEGIN_PROVIDER [ double precision, NatOrbsCI_mos, (mo_num, mo_num) ] + implicit none + BEGIN_DOC + ! Rotation matrix from current MOs to the CI natural MOs + END_DOC + integer :: p,q + + NatOrbsCI_mos(:,:) = 0.d0 + + do q = 1,mo_num + NatOrbsCI_mos(q,q) = 1.d0 + enddo + + do q = 1,n_act_orb + do p = 1,n_act_orb + NatOrbsCI_mos(list_act(p),list_act(q)) = natorbsCI(p,q) + enddo + enddo +END_PROVIDER + + BEGIN_PROVIDER [real*8, NatOrbsFCI, (ao_num,mo_num)] implicit none BEGIN_DOC ! FCI natural orbitals END_DOC - integer :: i,j, p, q - real*8 :: d(n_act_orb) - NatOrbsFCI(:,:)=mo_coef(:,:) - - do j=1,ao_num - do p=1,n_act_orb - d(p)=0.D0 - end do - do p=1,n_act_orb - do q=1,n_act_orb - d(p)+=NatOrbsFCI(j,list_act(q))*natorbsCI(q,p) - end do - end do - do p=1,n_act_orb - NatOrbsFCI(j,list_act(p))=d(p) - end do - end do - -! call dgemm('N','T', ao_num,mo_num,mo_num,1.d0, & -! NatOrbsFCI, size(NatOrbsFCI,1), & -! Umat, size(Umat,1), 0.d0, & -! NewOrbs, size(NewOrbs,1)) + call dgemm('N','N', ao_num,mo_num,mo_num,1.d0, & + mo_coef, size(mo_coef,1), & + NatOrbsCI_mos, size(NatOrbsCI_mos,1), 0.d0, & + NatOrbsFCI, size(NatOrbsFCI,1)) END_PROVIDER diff --git a/src/mo_two_e_ints/four_idx_novvvv.irp.f b/src/mo_two_e_ints/four_idx_novvvv.irp.f new file mode 100644 index 00000000..124c946a --- /dev/null +++ b/src/mo_two_e_ints/four_idx_novvvv.irp.f @@ -0,0 +1,202 @@ +BEGIN_PROVIDER [ double precision, mo_coef_novirt, (ao_num,n_core_inact_act_orb) ] + implicit none + BEGIN_DOC + ! MO coefficients without virtual MOs + END_DOC + integer :: j,jj + + do j=1,n_core_inact_act_orb + jj = list_core_inact_act(j) + mo_coef_novirt(:,j) = mo_coef(:,jj) + enddo + +END_PROVIDER + +subroutine ao_to_mo_novirt(A_ao,LDA_ao,A_mo,LDA_mo) + implicit none + BEGIN_DOC + ! Transform A from the |AO| basis to the |MO| basis excluding virtuals + ! + ! $C^\dagger.A_{ao}.C$ + END_DOC + integer, intent(in) :: LDA_ao,LDA_mo + double precision, intent(in) :: A_ao(LDA_ao,ao_num) + double precision, intent(out) :: A_mo(LDA_mo,n_core_inact_act_orb) + double precision, allocatable :: T(:,:) + + allocate ( T(ao_num,n_core_inact_act_orb) ) + !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T + + call dgemm('N','N', ao_num, n_core_inact_act_orb, ao_num, & + 1.d0, A_ao,LDA_ao, & + mo_coef_novirt, size(mo_coef_novirt,1), & + 0.d0, T, size(T,1)) + + call dgemm('T','N', n_core_inact_act_orb, n_core_inact_act_orb, ao_num,& + 1.d0, mo_coef_novirt,size(mo_coef_novirt,1), & + T, ao_num, & + 0.d0, A_mo, size(A_mo,1)) + + deallocate(T) +end + + +subroutine four_idx_novvvv + use map_module + implicit none + BEGIN_DOC + ! Retransform MO integrals for next CAS-SCF step + END_DOC + integer :: i,j,k,l,n_integrals + double precision, allocatable :: f(:,:,:), d(:,:), T(:,:,:,:) + double precision, external :: get_ao_two_e_integral + integer(key_kind), allocatable :: idx(:) + real(integral_kind), allocatable :: values(:) + + integer :: p,q,r,s + double precision, allocatable :: ijij(:), ijji(:), jqjs(:,:,:), jqrj(:,:,:) + double precision :: c + allocate (jqjs(mo_num,ao_num,ao_num), jqrj(mo_num,ao_num,ao_num)) + + allocate( T(n_core_inact_act_orb,n_core_inact_act_orb,ao_num,ao_num) ) + + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP SHARED(mo_num,ao_num,T,n_core_inact_act_orb, mo_coef_transp, & + !$OMP mo_integrals_threshold,mo_coef,mo_integrals_map, & + !$OMP list_core_inact_act,jqjs,jqrj,ao_integrals_map) & + !$OMP PRIVATE(i,j,k,l,p,q,r,s,idx,values,n_integrals, & + !$OMP f,d,c,ijij,ijji) + allocate(f(ao_num,ao_num,ao_num), d(mo_num,mo_num), & + idx(mo_num*mo_num), values(mo_num*mo_num) ) + allocate(ijij(mo_num), ijji(mo_num)) + + ! + !$OMP DO + do s=1,ao_num + T(:,:,:,s) = 0.d0 + jqjs(:,:,s) = 0.d0 + jqrj(:,:,s) = 0.d0 + enddo + !$OMP END DO + + !$OMP DO + do s=1,ao_num + do r=1,ao_num + do q=1,ao_num + do p=1,r + f(p,q,r) = get_ao_two_e_integral(p,q,r,s,ao_integrals_map) + f(r,q,p) = f(p,q,r) + enddo + enddo + enddo + ! f(p,q,r) = + + do r=1,ao_num + call ao_to_mo_novirt(f(1,1,r),size(f,1),T(1,1,r,s),size(T,1)) + enddo + ! T(i,j,p,q) = + + ! Diagonal + do r=1,ao_num + do q=1,ao_num + do p=1,ao_num + if (dabs(f(p,q,r)) >= mo_integrals_threshold) then + do i=1,mo_num + jqjs(i,q,s) = jqjs(i,q,s) + mo_coef_transp(i,p) * f(p,q,r) * mo_coef_transp(i,r) + enddo + endif + enddo + enddo + enddo + + enddo + !$OMP END DO NOWAIT + + !$OMP DO + do s=1,ao_num + do r=1,ao_num + do q=1,r + do p=1,ao_num + f(p,q,r) = get_ao_two_e_integral(p,q,s,r,ao_integrals_map) + f(p,r,q) = f(p,q,r) + enddo + enddo + enddo + ! f(p,q,r) = + + ! Diagonal + do r=1,ao_num + do q=1,ao_num + do p=1,ao_num + if (dabs(f(p,q,r)) >= mo_integrals_threshold) then + do i=1,mo_num + jqrj(i,q,s) = jqrj(i,q,s) + mo_coef_transp(i,p) * f(p,q,r) * mo_coef_transp(i,r) + enddo + endif + enddo + enddo + enddo + + enddo + !$OMP END DO NOWAIT + + !$OMP BARRIER + + !$OMP DO + do i=1,mo_num + ijij(:) = 0.d0 + ijji(:) = 0.d0 + do s=1,ao_num + do q=1,ao_num + do j=1,mo_num + c = mo_coef_transp(j,q) * mo_coef_transp(j,s) + ijij(j) = ijij(j) + jqjs(i,q,s) * c + ijji(j) = ijji(j) + jqrj(i,q,s) * c + enddo + enddo + enddo + do j=1,mo_num + call two_e_integrals_index(i,j,i,j,idx(j)) + values(j) = ijij(j) + enddo + do j=1,mo_num + call two_e_integrals_index(i,j,j,i,idx(mo_num+j)) + values(mo_num+j) = ijji(j) + enddo + call map_append(mo_integrals_map, idx, values, 2*mo_num) + enddo + !$OMP END DO + + !$OMP DO + do j=1,n_core_inact_act_orb + do i=1,n_core_inact_act_orb + do s=1,ao_num + do r=1,ao_num + f(r,s,1) = T(i,j,r,s) + enddo + enddo + call ao_to_mo(f,size(f,1),d,size(d,1)) + n_integrals = 0 + do l=1,mo_num + do k=1,mo_num + n_integrals+=1 + call two_e_integrals_index(list_core_inact_act(i),list_core_inact_act(j),k,l,idx(n_integrals)) + values(n_integrals) = d(k,l) + enddo + enddo + call map_append(mo_integrals_map, idx, values, n_integrals) + enddo + enddo + !$OMP END DO + deallocate(f,d,ijij,ijji,idx,values) + + !$OMP END PARALLEL + + deallocate(T,jqrj,jqjs) + + + call map_sort(mo_integrals_map) + call map_unique(mo_integrals_map) + call map_shrink(mo_integrals_map,real(mo_integrals_threshold,integral_kind)) + +end diff --git a/src/mo_two_e_ints/mo_bi_integrals.irp.f b/src/mo_two_e_ints/mo_bi_integrals.irp.f index fccf22a6..bca3df1a 100644 --- a/src/mo_two_e_ints/mo_bi_integrals.irp.f +++ b/src/mo_two_e_ints/mo_bi_integrals.irp.f @@ -22,16 +22,13 @@ end BEGIN_PROVIDER [ logical, mo_two_e_integrals_in_map ] use map_module implicit none - integer(bit_kind) :: mask_ijkl(N_int,4) - integer(bit_kind) :: mask_ijk(N_int,3) - BEGIN_DOC ! If True, the map of MO two-electron integrals is provided END_DOC + integer(bit_kind) :: mask_ijkl(N_int,4) + integer(bit_kind) :: mask_ijk(N_int,3) + double precision :: cpu_1, cpu_2, wall_1, wall_2 - ! The following line avoids a subsequent crash when the memory used is more - ! than half of the virtual memory, due to a fork in zcat when reading arrays - ! with EZFIO PROVIDE mo_class mo_two_e_integrals_in_map = .True. @@ -49,106 +46,28 @@ BEGIN_PROVIDER [ logical, mo_two_e_integrals_in_map ] print *, '---------------------------------' print *, '' + call wall_time(wall_1) + call cpu_time(cpu_1) + if(no_vvvv_integrals)then - integer :: i,j,k,l - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I I I !!!!!!!!!!!!!!!!!!!! - ! (core+inact+act) ^ 4 - ! - print*, '' - print*, '' - do i = 1,N_int - mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,4) = core_inact_act_bitmask_4(i,1) - enddo - call add_integrals_to_map(mask_ijkl) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I V V !!!!!!!!!!!!!!!!!!!! - ! (core+inact+act) ^ 2 (virt) ^2 - ! = J_iv - print*, '' - print*, '' - do i = 1,N_int - mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,2) = virt_bitmask(i,1) - mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,4) = virt_bitmask(i,1) - enddo - call add_integrals_to_map(mask_ijkl) - - ! (core+inact+act) ^ 2 (virt) ^2 - ! = (iv|iv) - print*, '' - print*, '' - do i = 1,N_int - mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,3) = virt_bitmask(i,1) - mask_ijkl(i,4) = virt_bitmask(i,1) - enddo - call add_integrals_to_map(mask_ijkl) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! V V V !!!!!!!!!!!!!!!!!!!!!!! - if(.not.no_vvv_integrals)then - print*, '' - print*, ' and ' - do i = 1,N_int - mask_ijk(i,1) = virt_bitmask(i,1) - mask_ijk(i,2) = virt_bitmask(i,1) - mask_ijk(i,3) = virt_bitmask(i,1) - enddo - call add_integrals_to_map_three_indices(mask_ijk) - endif - - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I I I V !!!!!!!!!!!!!!!!!!!! - ! (core+inact+act) ^ 3 (virt) ^1 - ! - print*, '' - print*, '' - do i = 1,N_int - mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,4) = virt_bitmask(i,1) - enddo - call add_integrals_to_map(mask_ijkl) - !!!!!!!!!!!!!!!!!!!!!!!!!!!!!! I V V V !!!!!!!!!!!!!!!!!!!! - ! (core+inact+act) ^ 1 (virt) ^3 - ! - if(.not.no_ivvv_integrals)then - print*, '' - print*, '' - do i = 1,N_int - mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) - mask_ijkl(i,2) = virt_bitmask(i,1) - mask_ijkl(i,3) = virt_bitmask(i,1) - mask_ijkl(i,4) = virt_bitmask(i,1) - enddo - call add_integrals_to_map_no_exit_34(mask_ijkl) - endif - + call four_idx_novvvv else call add_integrals_to_map(full_ijkl_bitmask_4) - -! call four_index_transform_zmq(ao_integrals_map,mo_integrals_map, & -! mo_coef, size(mo_coef,1), & -! 1, 1, 1, 1, ao_num, ao_num, ao_num, ao_num, & -! 1, 1, 1, 1, mo_num, mo_num, mo_num, mo_num) -! -! call four_index_transform_block(ao_integrals_map,mo_integrals_map, & -! mo_coef, size(mo_coef,1), & -! 1, 1, 1, 1, ao_num, ao_num, ao_num, ao_num, & -! 1, 1, 1, 1, mo_num, mo_num, mo_num, mo_num) -! -! call four_index_transform(ao_integrals_map,mo_integrals_map, & -! mo_coef, size(mo_coef,1), & -! 1, 1, 1, 1, ao_num, ao_num, ao_num, ao_num, & -! 1, 1, 1, 1, mo_num, mo_num, mo_num, mo_num) - - integer*8 :: get_mo_map_size, mo_map_size - mo_map_size = get_mo_map_size() - - print*,'Molecular integrals provided' endif + + call wall_time(wall_2) + call cpu_time(cpu_2) + + integer*8 :: get_mo_map_size, mo_map_size + mo_map_size = get_mo_map_size() + + double precision, external :: map_mb + print*,'Molecular integrals provided:' + print*,' Size of MO map ', map_mb(mo_integrals_map) ,'MB' + print*,' Number of MO integrals: ', mo_map_size + print*,' cpu time :',cpu_2 - cpu_1, 's' + print*,' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1), ')' + if (write_mo_two_e_integrals.and.mpi_master) then call ezfio_set_work_empty(.False.) call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints',mo_integrals_map) @@ -185,7 +104,7 @@ subroutine add_integrals_to_map(mask_ijkl) integer :: size_buffer integer(key_kind),allocatable :: buffer_i(:) real(integral_kind),allocatable :: buffer_value(:) - double precision :: map_mb + double precision, external :: map_mb integer :: i1,j1,k1,l1, ii1, kmax, thread_num integer :: i2,i3,i4 @@ -247,12 +166,9 @@ subroutine add_integrals_to_map(mask_ijkl) endif size_buffer = min(ao_num*ao_num*ao_num,16000000) - print*, 'Providing the molecular integrals ' print*, 'Buffers : ', 8.*(mo_num*(n_j)*(n_k+1) + mo_num+& ao_num+ao_num*ao_num+ size_buffer*3)/(1024*1024), 'MB / core' - call wall_time(wall_1) - call cpu_time(cpu_1) double precision :: accu_bis accu_bis = 0.d0 @@ -452,12 +368,6 @@ subroutine add_integrals_to_map(mask_ijkl) deallocate(list_ijkl) - print*,'Molecular integrals provided:' - print*,' Size of MO map ', map_mb(mo_integrals_map) ,'MB' - print*,' Number of MO integrals: ', mo_map_size - print*,' cpu time :',cpu_2 - cpu_1, 's' - print*,' wall time :',wall_2 - wall_1, 's ( x ', (cpu_2-cpu_1)/(wall_2-wall_1), ')' - end From a744bc30d4f00944c3232d6a7724b2af6adb9fe0 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Fri, 5 Jul 2019 23:53:05 +0200 Subject: [PATCH 51/59] Fast 4-idx transformation --- src/casscf/bielec.irp.f | 1 - src/casscf/casscf.irp.f | 7 +- src/mo_two_e_ints/EZFIO.cfg | 21 ---- src/mo_two_e_ints/four_idx_novvvv.irp.f | 156 ++++++++++-------------- src/mo_two_e_ints/mo_bi_integrals.irp.f | 24 +--- 5 files changed, 70 insertions(+), 139 deletions(-) diff --git a/src/casscf/bielec.irp.f b/src/casscf/bielec.irp.f index 1c6d9e6b..0a44f994 100644 --- a/src/casscf/bielec.irp.f +++ b/src/casscf/bielec.irp.f @@ -153,4 +153,3 @@ BEGIN_PROVIDER [real*8, bielecCI, (n_act_orb,n_act_orb,n_act_orb, mo_num)] !$OMP END PARALLEL DO END_PROVIDER - diff --git a/src/casscf/casscf.irp.f b/src/casscf/casscf.irp.f index 3fc6fd8e..8fe77fcc 100644 --- a/src/casscf/casscf.irp.f +++ b/src/casscf/casscf.irp.f @@ -4,10 +4,8 @@ program casscf ! TODO : Put the documentation of the program here END_DOC no_vvvv_integrals = .True. - no_ivvv_integrals = .True. - no_vvv_integrals = .True. pt2_max = 0.02 - SOFT_TOUCH no_vvvv_integrals no_vvv_integrals pt2_max + SOFT_TOUCH no_vvvv_integrals pt2_max call run end @@ -41,8 +39,7 @@ subroutine run psi_det = psi_det_sorted psi_coef = psi_coef_sorted read_wf = .True. - call map_deinit(mo_integrals_map) - FREE mo_two_e_integrals_in_map mo_integrals_map + call clear_mo_map SOFT_TOUCH mo_coef N_det pt2_max psi_det psi_coef enddo diff --git a/src/mo_two_e_ints/EZFIO.cfg b/src/mo_two_e_ints/EZFIO.cfg index 57681638..bec74552 100644 --- a/src/mo_two_e_ints/EZFIO.cfg +++ b/src/mo_two_e_ints/EZFIO.cfg @@ -11,24 +11,3 @@ interface: ezfio,provider,ocaml default: 1.e-15 ezfio_name: threshold_mo -[no_vvvv_integrals] -type: logical -doc: If `True`, computes all integrals except for the integrals having 4 virtual indices -interface: ezfio,provider,ocaml -default: False -ezfio_name: no_vvvv_integrals - -[no_ivvv_integrals] -type: logical -doc: Can be switched on only if `no_vvvv_integrals` is `True`, then does not compute the integrals with 3 virtual indices and 1 belonging to the core inactive active orbitals -interface: ezfio,provider,ocaml -default: False -ezfio_name: no_ivvv_integrals - -[no_vvv_integrals] -type: logical -doc: Can be switched on only if `no_vvvv_integrals` is `True`, then does not compute the integrals with 3 virtual orbitals -interface: ezfio,provider,ocaml -default: False -ezfio_name: no_vvv_integrals - diff --git a/src/mo_two_e_ints/four_idx_novvvv.irp.f b/src/mo_two_e_ints/four_idx_novvvv.irp.f index 124c946a..054d0a35 100644 --- a/src/mo_two_e_ints/four_idx_novvvv.irp.f +++ b/src/mo_two_e_ints/four_idx_novvvv.irp.f @@ -1,3 +1,12 @@ +BEGIN_PROVIDER [ logical, no_vvvv_integrals ] + implicit none + BEGIN_DOC +! If `True`, computes all integrals except for the integrals having 3 or 4 virtual indices + END_DOC + + no_vvvv_integrals = .False. +END_PROVIDER + BEGIN_PROVIDER [ double precision, mo_coef_novirt, (ao_num,n_core_inact_act_orb) ] implicit none BEGIN_DOC @@ -48,134 +57,66 @@ subroutine four_idx_novvvv ! Retransform MO integrals for next CAS-SCF step END_DOC integer :: i,j,k,l,n_integrals - double precision, allocatable :: f(:,:,:), d(:,:), T(:,:,:,:) + double precision, allocatable :: f(:,:,:), f2(:,:,:), d(:,:), T(:,:,:,:), T2(:,:,:,:) double precision, external :: get_ao_two_e_integral integer(key_kind), allocatable :: idx(:) real(integral_kind), allocatable :: values(:) integer :: p,q,r,s - double precision, allocatable :: ijij(:), ijji(:), jqjs(:,:,:), jqrj(:,:,:) double precision :: c - allocate (jqjs(mo_num,ao_num,ao_num), jqrj(mo_num,ao_num,ao_num)) - - allocate( T(n_core_inact_act_orb,n_core_inact_act_orb,ao_num,ao_num) ) + allocate( T(n_core_inact_act_orb,n_core_inact_act_orb,ao_num,ao_num) , & + T2(n_core_inact_act_orb,n_core_inact_act_orb,ao_num,ao_num) ) !$OMP PARALLEL DEFAULT(NONE) & !$OMP SHARED(mo_num,ao_num,T,n_core_inact_act_orb, mo_coef_transp, & !$OMP mo_integrals_threshold,mo_coef,mo_integrals_map, & - !$OMP list_core_inact_act,jqjs,jqrj,ao_integrals_map) & + !$OMP list_core_inact_act,T2,ao_integrals_map) & !$OMP PRIVATE(i,j,k,l,p,q,r,s,idx,values,n_integrals, & - !$OMP f,d,c,ijij,ijji) - allocate(f(ao_num,ao_num,ao_num), d(mo_num,mo_num), & + !$OMP f,f2,d,c) + allocate(f(ao_num,ao_num,ao_num), f2(ao_num,ao_num,ao_num), d(mo_num,mo_num), & idx(mo_num*mo_num), values(mo_num*mo_num) ) - allocate(ijij(mo_num), ijji(mo_num)) ! - !$OMP DO - do s=1,ao_num - T(:,:,:,s) = 0.d0 - jqjs(:,:,s) = 0.d0 - jqrj(:,:,s) = 0.d0 - enddo - !$OMP END DO - !$OMP DO do s=1,ao_num do r=1,ao_num do q=1,ao_num do p=1,r - f(p,q,r) = get_ao_two_e_integral(p,q,r,s,ao_integrals_map) - f(r,q,p) = f(p,q,r) + f (p,q,r) = get_ao_two_e_integral(p,q,r,s,ao_integrals_map) + f (r,q,p) = f(p,q,r) enddo enddo enddo - ! f(p,q,r) = - - do r=1,ao_num - call ao_to_mo_novirt(f(1,1,r),size(f,1),T(1,1,r,s),size(T,1)) - enddo - ! T(i,j,p,q) = - - ! Diagonal do r=1,ao_num do q=1,ao_num do p=1,ao_num - if (dabs(f(p,q,r)) >= mo_integrals_threshold) then - do i=1,mo_num - jqjs(i,q,s) = jqjs(i,q,s) + mo_coef_transp(i,p) * f(p,q,r) * mo_coef_transp(i,r) - enddo - endif + f2(p,q,r) = f(p,r,q) enddo enddo enddo - - enddo - !$OMP END DO NOWAIT + ! f (p,q,r) = + ! f2(p,q,r) = - !$OMP DO - do s=1,ao_num do r=1,ao_num - do q=1,r - do p=1,ao_num - f(p,q,r) = get_ao_two_e_integral(p,q,s,r,ao_integrals_map) - f(p,r,q) = f(p,q,r) - enddo - enddo + call ao_to_mo_novirt(f (1,1,r),size(f ,1),T (1,1,r,s),size(T,1)) + call ao_to_mo_novirt(f2(1,1,r),size(f2,1),T2(1,1,r,s),size(T,1)) enddo - ! f(p,q,r) = + ! T (i,j,p,q) = + ! T2(i,j,p,q) = - ! Diagonal - do r=1,ao_num - do q=1,ao_num - do p=1,ao_num - if (dabs(f(p,q,r)) >= mo_integrals_threshold) then - do i=1,mo_num - jqrj(i,q,s) = jqrj(i,q,s) + mo_coef_transp(i,p) * f(p,q,r) * mo_coef_transp(i,r) - enddo - endif - enddo - enddo - enddo - enddo - !$OMP END DO NOWAIT - - !$OMP BARRIER - - !$OMP DO - do i=1,mo_num - ijij(:) = 0.d0 - ijji(:) = 0.d0 - do s=1,ao_num - do q=1,ao_num - do j=1,mo_num - c = mo_coef_transp(j,q) * mo_coef_transp(j,s) - ijij(j) = ijij(j) + jqjs(i,q,s) * c - ijji(j) = ijji(j) + jqrj(i,q,s) * c - enddo - enddo - enddo - do j=1,mo_num - call two_e_integrals_index(i,j,i,j,idx(j)) - values(j) = ijij(j) - enddo - do j=1,mo_num - call two_e_integrals_index(i,j,j,i,idx(mo_num+j)) - values(mo_num+j) = ijji(j) - enddo - call map_append(mo_integrals_map, idx, values, 2*mo_num) - enddo - !$OMP END DO + !$OMP END DO !$OMP DO do j=1,n_core_inact_act_orb do i=1,n_core_inact_act_orb do s=1,ao_num do r=1,ao_num - f(r,s,1) = T(i,j,r,s) + f (r,s,1) = T (i,j,r,s) + f2(r,s,1) = T2(i,j,r,s) enddo enddo - call ao_to_mo(f,size(f,1),d,size(d,1)) + call ao_to_mo(f ,size(f ,1),d,size(d,1)) n_integrals = 0 do l=1,mo_num do k=1,mo_num @@ -185,14 +126,25 @@ subroutine four_idx_novvvv enddo enddo call map_append(mo_integrals_map, idx, values, n_integrals) + + call ao_to_mo(f2,size(f2,1),d,size(d,1)) + n_integrals = 0 + do l=1,mo_num + do k=1,mo_num + n_integrals+=1 + call two_e_integrals_index(list_core_inact_act(i),k,list_core_inact_act(j),l,idx(n_integrals)) + values(n_integrals) = d(k,l) + enddo + enddo + call map_append(mo_integrals_map, idx, values, n_integrals) enddo enddo !$OMP END DO - deallocate(f,d,ijij,ijji,idx,values) + deallocate(f,f2,d,idx,values) !$OMP END PARALLEL - deallocate(T,jqrj,jqjs) + deallocate(T,T2) call map_sort(mo_integrals_map) @@ -200,3 +152,29 @@ subroutine four_idx_novvvv call map_shrink(mo_integrals_map,real(mo_integrals_threshold,integral_kind)) end + +subroutine four_idx_novvvv2 + use bitmasks + implicit none + integer :: i + integer(bit_kind) :: mask_ijkl(N_int,4) + + print*, '' + do i = 1,N_int + mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,2) = full_ijkl_bitmask_4(i,1) + mask_ijkl(i,3) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,4) = full_ijkl_bitmask_4(i,1) + enddo + call add_integrals_to_map(mask_ijkl) + + print*, '' + do i = 1,N_int + mask_ijkl(i,1) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,2) = core_inact_act_bitmask_4(i,1) + mask_ijkl(i,3) = virt_bitmask(i,1) + mask_ijkl(i,4) = virt_bitmask(i,1) + enddo + call add_integrals_to_map(mask_ijkl) + +end diff --git a/src/mo_two_e_ints/mo_bi_integrals.irp.f b/src/mo_two_e_ints/mo_bi_integrals.irp.f index bca3df1a..a9983e51 100644 --- a/src/mo_two_e_ints/mo_bi_integrals.irp.f +++ b/src/mo_two_e_ints/mo_bi_integrals.irp.f @@ -120,10 +120,6 @@ subroutine add_integrals_to_map(mask_ijkl) call bitstring_to_list( mask_ijkl(1,2), list_ijkl(1,2), n_j, N_int ) call bitstring_to_list( mask_ijkl(1,3), list_ijkl(1,3), n_k, N_int ) call bitstring_to_list( mask_ijkl(1,4), list_ijkl(1,4), n_l, N_int ) - character*(2048) :: output(1) - print *, 'i' - call bitstring_to_str( output(1), mask_ijkl(1,1), N_int ) - print *, trim(output(1)) j = 0 do i = 1, N_int j += popcnt(mask_ijkl(i,1)) @@ -132,9 +128,6 @@ subroutine add_integrals_to_map(mask_ijkl) return endif - print*, 'j' - call bitstring_to_str( output(1), mask_ijkl(1,2), N_int ) - print *, trim(output(1)) j = 0 do i = 1, N_int j += popcnt(mask_ijkl(i,2)) @@ -143,9 +136,6 @@ subroutine add_integrals_to_map(mask_ijkl) return endif - print*, 'k' - call bitstring_to_str( output(1), mask_ijkl(1,3), N_int ) - print *, trim(output(1)) j = 0 do i = 1, N_int j += popcnt(mask_ijkl(i,3)) @@ -154,9 +144,6 @@ subroutine add_integrals_to_map(mask_ijkl) return endif - print*, 'l' - call bitstring_to_str( output(1), mask_ijkl(1,4), N_int ) - print *, trim(output(1)) j = 0 do i = 1, N_int j += popcnt(mask_ijkl(i,4)) @@ -171,6 +158,7 @@ subroutine add_integrals_to_map(mask_ijkl) double precision :: accu_bis accu_bis = 0.d0 + call wall_time(wall_1) !$OMP PARALLEL PRIVATE(l1,k1,j1,i1,i2,i3,i4,i,j,k,l,c, ii1,kmax, & !$OMP two_e_tmp_0_idx, two_e_tmp_0, two_e_tmp_1,two_e_tmp_2,two_e_tmp_3,& @@ -414,10 +402,6 @@ subroutine add_integrals_to_map_three_indices(mask_ijk) call bitstring_to_list( mask_ijk(1,1), list_ijkl(1,1), n_i, N_int ) call bitstring_to_list( mask_ijk(1,2), list_ijkl(1,2), n_j, N_int ) call bitstring_to_list( mask_ijk(1,3), list_ijkl(1,3), n_k, N_int ) - character*(2048) :: output(1) - print*, 'i' - call bitstring_to_str( output(1), mask_ijk(1,1), N_int ) - print *, trim(output(1)) j = 0 do i = 1, N_int j += popcnt(mask_ijk(i,1)) @@ -426,9 +410,6 @@ subroutine add_integrals_to_map_three_indices(mask_ijk) return endif - print*, 'j' - call bitstring_to_str( output(1), mask_ijk(1,2), N_int ) - print *, trim(output(1)) j = 0 do i = 1, N_int j += popcnt(mask_ijk(i,2)) @@ -437,9 +418,6 @@ subroutine add_integrals_to_map_three_indices(mask_ijk) return endif - print*, 'k' - call bitstring_to_str( output(1), mask_ijk(1,3), N_int ) - print *, trim(output(1)) j = 0 do i = 1, N_int j += popcnt(mask_ijk(i,3)) From 970fd8837ad447cab5ffba0a7a4fdbcef54ff33f Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Sat, 6 Jul 2019 01:04:50 +0200 Subject: [PATCH 52/59] OpenMP in Hessian --- src/casscf/hessian.irp.f | 94 +++++++++++++++++++++++++--------------- 1 file changed, 60 insertions(+), 34 deletions(-) diff --git a/src/casscf/hessian.irp.f b/src/casscf/hessian.irp.f index 75a27410..52be1b76 100644 --- a/src/casscf/hessian.irp.f +++ b/src/casscf/hessian.irp.f @@ -189,7 +189,7 @@ BEGIN_PROVIDER [real*8, hessmat2, (nMonoEx,nMonoEx)] ! END_DOC implicit none - integer :: i,j,t,u,a,b,indx,jndx,bstart,ustart + integer :: i,j,t,u,a,b,indx,jndx,bstart,ustart,indx_shift real*8 :: hessmat_itju real*8 :: hessmat_itja @@ -203,9 +203,14 @@ BEGIN_PROVIDER [real*8, hessmat2, (nMonoEx,nMonoEx)] write(6,*) ' nMonoEx = ',nMonoEx endif - indx=1 + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP SHARED(hessmat2,n_core_inact_orb,n_act_orb,n_virt_orb,nMonoEx) & + !$OMP PRIVATE(i,indx,jndx,j,ustart,t,u,a,bstart,indx_shift) + + !$OMP DO do i=1,n_core_inact_orb do t=1,n_act_orb + indx = t + (i-1)*n_act_orb jndx=indx do j=i,n_core_inact_orb if (i.eq.j) then @@ -214,31 +219,31 @@ BEGIN_PROVIDER [real*8, hessmat2, (nMonoEx,nMonoEx)] ustart=1 end if do u=ustart,n_act_orb - hessmat2(indx,jndx)=hessmat_itju(i,t,j,u) - hessmat2(jndx,indx)=hessmat2(indx,jndx) + hessmat2(jndx,indx)=hessmat_itju(i,t,j,u) jndx+=1 end do end do do j=1,n_core_inact_orb do a=1,n_virt_orb - hessmat2(indx,jndx)=hessmat_itja(i,t,j,a) - hessmat2(jndx,indx)=hessmat2(indx,jndx) + hessmat2(jndx,indx)=hessmat_itja(i,t,j,a) jndx+=1 end do end do do u=1,n_act_orb do a=1,n_virt_orb - hessmat2(indx,jndx)=hessmat_itua(i,t,u,a) - hessmat2(jndx,indx)=hessmat2(indx,jndx) + hessmat2(jndx,indx)=hessmat_itua(i,t,u,a) jndx+=1 end do end do - indx+=1 end do end do + !$OMP END DO NOWAIT - do i=1,n_core_inact_orb - do a=1,n_virt_orb + indx_shift = n_core_inact_orb*n_act_orb + !$OMP DO + do a=1,n_virt_orb + do i=1,n_core_inact_orb + indx = a + (i-1)*n_virt_orb + indx_shift jndx=indx do j=i,n_core_inact_orb if (i.eq.j) then @@ -247,24 +252,25 @@ BEGIN_PROVIDER [real*8, hessmat2, (nMonoEx,nMonoEx)] bstart=1 end if do b=bstart,n_virt_orb - hessmat2(indx,jndx)=hessmat_iajb(i,a,j,b) - hessmat2(jndx,indx)=hessmat2(indx,jndx) + hessmat2(jndx,indx)=hessmat_iajb(i,a,j,b) jndx+=1 end do end do do t=1,n_act_orb do b=1,n_virt_orb - hessmat2(indx,jndx)=hessmat_iatb(i,a,t,b) - hessmat2(jndx,indx)=hessmat2(indx,jndx) + hessmat2(jndx,indx)=hessmat_iatb(i,a,t,b) jndx+=1 end do end do - indx+=1 end do end do + !$OMP END DO NOWAIT - do t=1,n_act_orb - do a=1,n_virt_orb + indx_shift += n_core_inact_orb*n_virt_orb + !$OMP DO + do a=1,n_virt_orb + do t=1,n_act_orb + indx = a + (t-1)*n_virt_orb + indx_shift jndx=indx do u=t,n_act_orb if (t.eq.u) then @@ -273,14 +279,22 @@ BEGIN_PROVIDER [real*8, hessmat2, (nMonoEx,nMonoEx)] bstart=1 end if do b=bstart,n_virt_orb - hessmat2(indx,jndx)=hessmat_taub(t,a,u,b) - hessmat2(jndx,indx)=hessmat2(indx,jndx) + hessmat2(jndx,indx)=hessmat_taub(t,a,u,b) jndx+=1 end do end do - indx+=1 end do end do + !$OMP END DO + + !$OMP END PARALLEL + + do jndx=1,nMonoEx + do indx=1,jndx-1 + hessmat2(indx,jndx) = hessmat2(jndx,indx) + enddo + enddo + END_PROVIDER @@ -524,8 +538,8 @@ real*8 function hessmat_taub(t,a,u,b) tt=list_act(t) aa=list_virt(a) - if (t.eq.u) then - if (a.eq.b) then + if (t == u) then + if (a == b) then ! ta/ta t1=occnum(tt)*Fipq(aa,aa) t2=0.D0 @@ -581,8 +595,8 @@ real*8 function hessmat_taub(t,a,u,b) if (a.eq.b) then term-=0.5D0*(occnum(tt)*Fipq(uu,tt)+occnum(uu)*Fipq(tt,uu)) do v=1,n_act_orb - do x=1,n_act_orb - do y=1,n_act_orb + do y=1,n_act_orb + do x=1,n_act_orb term-=P0tuvx_no(t,v,x,y)*bielecCI_no(x,y,v,uu) term-=P0tuvx_no(u,v,x,y)*bielecCI_no(x,y,v,tt) end do @@ -602,29 +616,41 @@ BEGIN_PROVIDER [real*8, hessdiag, (nMonoEx)] ! the diagonal of the Hessian, needed for the Davidson procedure END_DOC implicit none - integer :: i,t,a,indx + integer :: i,t,a,indx,indx_shift real*8 :: hessmat_itju,hessmat_iajb,hessmat_taub - indx=0 + !$OMP PARALLEL DEFAULT(NONE) & + !$OMP SHARED(hessdiag,n_core_inact_orb,n_act_orb,n_virt_orb,nMonoEx) & + !$OMP PRIVATE(i,indx,t,a,indx_shift) + + !$OMP DO do i=1,n_core_inact_orb do t=1,n_act_orb - indx+=1 + indx = t + (i-1)*n_act_orb hessdiag(indx)=hessmat_itju(i,t,i,t) end do end do + !$OMP END DO NOWAIT - do i=1,n_core_inact_orb - do a=1,n_virt_orb - indx+=1 + indx_shift = n_core_inact_orb*n_act_orb + !$OMP DO + do a=1,n_virt_orb + do i=1,n_core_inact_orb + indx = a + (i-1)*n_virt_orb + indx_shift hessdiag(indx)=hessmat_iajb(i,a,i,a) end do end do + !$OMP END DO NOWAIT - do t=1,n_act_orb - do a=1,n_virt_orb - indx+=1 + indx_shift += n_core_inact_orb*n_virt_orb + !$OMP DO + do a=1,n_virt_orb + do t=1,n_act_orb + indx = a + (t-1)*n_virt_orb + indx_shift hessdiag(indx)=hessmat_taub(t,a,t,a) end do end do + !$OMP END DO + !$OMP END PARALLEL END_PROVIDER From 3f69f95275d62048437d0c43b754e54dab800b31 Mon Sep 17 00:00:00 2001 From: Anthony Scemama Date: Sat, 6 Jul 2019 02:17:07 +0200 Subject: [PATCH 53/59] Optimized Hessian --- src/casscf/hessian.irp.f | 73 ++++++++++++++++++++++++++++------------ 1 file changed, 52 insertions(+), 21 deletions(-) diff --git a/src/casscf/hessian.irp.f b/src/casscf/hessian.irp.f index 52be1b76..06aed6ef 100644 --- a/src/casscf/hessian.irp.f +++ b/src/casscf/hessian.irp.f @@ -536,6 +536,9 @@ real*8 function hessmat_taub(t,a,u,b) integer :: v3,x3 real*8 :: term,t1,t2,t3 + double precision,allocatable :: P0tuvx_no_t(:,:,:) + double precision :: bielec_pqxx_no_2(n_act_orb,n_act_orb) + double precision :: bielec_pxxq_no_2(n_act_orb,n_act_orb) tt=list_act(t) aa=list_virt(a) if (t == u) then @@ -545,59 +548,87 @@ real*8 function hessmat_taub(t,a,u,b) t2=0.D0 t3=0.D0 t1-=occnum(tt)*Fipq(tt,tt) + do x=1,n_act_orb + xx=list_act(x) + x3=x+n_core_inact_orb + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_inact_orb + t2+=P0tuvx_no(t,t,v,x)*bielec_pqxx_no(aa,aa,v3,x3) + end do + end do do v=1,n_act_orb vv=list_act(v) v3=v+n_core_inact_orb do x=1,n_act_orb xx=list_act(x) x3=x+n_core_inact_orb - t2+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx_no(aa,aa,v3,x3) & - +(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* & - bielec_pxxq_no(aa,x3,v3,aa)) - do y=1,n_act_orb - t3-=2.D0*P0tuvx_no(t,v,x,y)*bielecCI_no(t,v,y,xx) + t2+=(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v))* & + bielec_pxxq_no(aa,x3,v3,aa) + end do + end do + do y=1,n_act_orb + do x=1,n_act_orb + xx=list_act(x) + do v=1,n_act_orb + t3-=P0tuvx_no(t,v,x,y)*bielecCI_no(t,v,y,xx) end do end do end do - term=t1+t2+t3 + term=t1+2.d0*(t2+t3) else bb=list_virt(b) ! ta/tb b/=a - term=occnum(tt)*Fipq(aa,bb) + term=0.5d0*occnum(tt)*Fipq(aa,bb) + do x=1,n_act_orb + xx=list_act(x) + x3=x+n_core_inact_orb + do v=1,n_act_orb + vv=list_act(v) + v3=v+n_core_inact_orb + term = term + P0tuvx_no(t,t,v,x)*bielec_pqxx_no(aa,bb,v3,x3) + end do + end do do v=1,n_act_orb vv=list_act(v) v3=v+n_core_inact_orb do x=1,n_act_orb xx=list_act(x) x3=x+n_core_inact_orb - term+=2.D0*(P0tuvx_no(t,t,v,x)*bielec_pqxx_no(aa,bb,v3,x3) & - +(P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v)) & - *bielec_pxxq_no(aa,x3,v3,bb)) + term= term + (P0tuvx_no(t,x,v,t)+P0tuvx_no(t,x,t,v)) & + *bielec_pxxq_no(aa,x3,v3,bb) end do end do + term += term end if else ! ta/ub t/=u uu=list_act(u) bb=list_virt(b) - term=0.D0 - do v=1,n_act_orb - vv=list_act(v) - v3=v+n_core_inact_orb - do x=1,n_act_orb - xx=list_act(x) - x3=x+n_core_inact_orb - term+=2.D0*(P0tuvx_no(t,u,v,x)*bielec_pqxx_no(aa,bb,v3,x3) & - +(P0tuvx_no(t,x,v,u)+P0tuvx_no(t,x,u,v)) & - *bielec_pxxq_no(aa,x3,v3,bb)) + allocate(P0tuvx_no_t(n_act_orb,n_act_orb,n_act_orb)) + P0tuvx_no_t(:,:,:) = P0tuvx_no(t,:,:,:) + do x=1,n_act_orb + x3=x+n_core_inact_orb + do v=1,n_act_orb + v3=v+n_core_inact_orb + bielec_pqxx_no_2(v,x) = bielec_pqxx_no(aa,bb,v3,x3) + bielec_pxxq_no_2(v,x) = bielec_pxxq_no(aa,v3,x3,bb) end do end do + term=0.D0 + do x=1,n_act_orb + do v=1,n_act_orb + term += P0tuvx_no_t(u,v,x)*bielec_pqxx_no_2(v,x) + term += bielec_pxxq_no_2(x,v) * (P0tuvx_no_t(x,v,u)+P0tuvx_no_t(x,u,v)) + end do + end do + term = 6.d0*term if (a.eq.b) then term-=0.5D0*(occnum(tt)*Fipq(uu,tt)+occnum(uu)*Fipq(tt,uu)) do v=1,n_act_orb do y=1,n_act_orb do x=1,n_act_orb - term-=P0tuvx_no(t,v,x,y)*bielecCI_no(x,y,v,uu) + term-=P0tuvx_no_t(v,x,y)*bielecCI_no(x,y,v,uu) term-=P0tuvx_no(u,v,x,y)*bielecCI_no(x,y,v,tt) end do end do From e7834fa7c5909488755a1e5c2166323a1a58fa16 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner Date: Mon, 8 Jul 2019 13:13:48 +0200 Subject: [PATCH 54/59] beginning to make work --- src/casscf/test_pert_2rdm.irp.f | 29 +++++ src/cipsi/lock_2rdm.irp.f | 0 src/cipsi/pert_rdm_providers.irp.f | 21 +++- src/cipsi/selection.irp.f | 12 +- src/cipsi/update_2rdm.irp.f | 191 +++++++++++++++++++++++++---- 5 files changed, 219 insertions(+), 34 deletions(-) create mode 100644 src/casscf/test_pert_2rdm.irp.f create mode 100644 src/cipsi/lock_2rdm.irp.f diff --git a/src/casscf/test_pert_2rdm.irp.f b/src/casscf/test_pert_2rdm.irp.f new file mode 100644 index 00000000..89d7bc8a --- /dev/null +++ b/src/casscf/test_pert_2rdm.irp.f @@ -0,0 +1,29 @@ +program test_pert_2rdm + implicit none + read_wf = .True. + touch read_wf + call get_pert_2rdm + integer :: i,j,k,l,ii,jj,kk,ll + double precision :: accu , get_two_e_integral, integral + accu = 0.d0 + print*,'n_orb_pert_rdm = ',n_orb_pert_rdm + do ii = 1, n_orb_pert_rdm + i = list_orb_pert_rdm(ii) + do jj = 1, n_orb_pert_rdm + j = list_orb_pert_rdm(jj) + do kk = 1, n_orb_pert_rdm + k= list_orb_pert_rdm(kk) + do ll = 1, n_orb_pert_rdm + l = list_orb_pert_rdm(ll) + integral = get_two_e_integral(i,j,k,l,mo_integrals_map) +! if(dabs(pert_2rdm_provider(ii,jj,kk,ll) * integral).gt.1.d-12)then +! print*,i,j,k,l +! print*,pert_2rdm_provider(ii,jj,kk,ll) * integral,pert_2rdm_provider(ii,jj,kk,ll), pert_2rdm_provider(ii,jj,kk,ll), integral +! endif + accu += pert_2rdm_provider(ii,jj,kk,ll) * integral + enddo + enddo + enddo + enddo + print*,'accu = ',accu +end diff --git a/src/cipsi/lock_2rdm.irp.f b/src/cipsi/lock_2rdm.irp.f new file mode 100644 index 00000000..e69de29b diff --git a/src/cipsi/pert_rdm_providers.irp.f b/src/cipsi/pert_rdm_providers.irp.f index 9cf8fba7..85bea747 100644 --- a/src/cipsi/pert_rdm_providers.irp.f +++ b/src/cipsi/pert_rdm_providers.irp.f @@ -1,5 +1,12 @@ use bitmasks +use omp_lib + +BEGIN_PROVIDER [ integer(omp_lock_kind), pert_2rdm_lock] + use f77_zmq + implicit none + call omp_init_lock(pert_2rdm_lock) +END_PROVIDER BEGIN_PROVIDER [logical , pert_2rdm ] implicit none @@ -29,13 +36,13 @@ BEGIN_PROVIDER [double precision, pert_2rdm_provider, (n_orb_pert_rdm,n_orb_pert END_PROVIDER -subroutine fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, variance, norm, mat, buf, psi_det_connection, psi_coef_connection, n_det_connection) +subroutine fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, variance, norm, mat, buf, psi_det_connection, psi_coef_connection_reverse, n_det_connection) use bitmasks use selection_types implicit none integer, intent(in) :: n_det_connection - double precision, intent(in) :: psi_coef_connection(n_det_connection,N_states) + double precision, intent(in) :: psi_coef_connection_reverse(N_states,n_det_connection) integer(bit_kind), intent(in) :: psi_det_connection(N_int,2,n_det_connection) integer, intent(in) :: i_generator, sp, h1, h2 double precision, intent(in) :: mat(N_states, mo_num, mo_num) @@ -136,7 +143,9 @@ subroutine fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fo Hii = diag_H_mat_elem_fock(psi_det_generators(1,1,i_generator),det,fock_diag_tmp,N_int) sum_e_pert = 0d0 - + integer :: degree + call get_excitation_degree(det,HF_bitmask,degree,N_int) + if(degree == 2)cycle do istate=1,N_states delta_E = E0(istate) - Hii + E_shift alpha_h_psi = mat(istate, p1, p2) @@ -147,6 +156,7 @@ subroutine fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fo endif e_pert = 0.5d0 * (tmp - delta_E) coef(istate) = e_pert / alpha_h_psi + print*,e_pert,coef,alpha_h_psi pt2(istate) = pt2(istate) + e_pert variance(istate) = variance(istate) + alpha_h_psi * alpha_h_psi norm(istate) = norm(istate) + coef(istate) * coef(istate) @@ -154,19 +164,20 @@ subroutine fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fo if (weight_selection /= 5) then ! Energy selection sum_e_pert = sum_e_pert + e_pert * selection_weight(istate) + else ! Variance selection sum_e_pert = sum_e_pert - alpha_h_psi * alpha_h_psi * selection_weight(istate) endif end do - - call give_2rdm_pert_contrib(det,coef,psi_det_connection,psi_coef_connection,n_det_connection,nkeys,keys,values,sze_buff) + call give_2rdm_pert_contrib(det,coef,psi_det_connection,psi_coef_connection_reverse,n_det_connection,nkeys,keys,values,sze_buff) if(sum_e_pert <= buf%mini) then call add_to_selection_buffer(buf, det, sum_e_pert) end if end do end do + call update_keys_values(keys,values,nkeys,n_orb_pert_rdm,pert_2rdm_provider,pert_2rdm_lock) end diff --git a/src/cipsi/selection.irp.f b/src/cipsi/selection.irp.f index 71442538..248876ef 100644 --- a/src/cipsi/selection.irp.f +++ b/src/cipsi/selection.irp.f @@ -249,7 +249,7 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d integer,allocatable :: tmp_array(:) integer(bit_kind), allocatable :: minilist(:, :, :), fullminilist(:, :, :) logical, allocatable :: banned(:,:,:), bannedOrb(:,:) - double precision, allocatable :: coef_fullminilist(:,:) + double precision, allocatable :: coef_fullminilist_rev(:,:) double precision, allocatable :: mat(:,:,:) @@ -549,9 +549,11 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d allocate (fullminilist (N_int, 2, fullinteresting(0)), & minilist (N_int, 2, interesting(0)) ) if(pert_2rdm)then - allocate(coef_fullminilist(fullinteresting(0),N_states)) + allocate(coef_fullminilist_rev(N_states,fullinteresting(0))) do i=1,fullinteresting(0) - coef_fullminilist(i,:) = psi_coef_sorted(fullinteresting(i),:) + do j = 1, N_states + coef_fullminilist_rev(j,i) = psi_coef_sorted(fullinteresting(i),j) + enddo enddo endif do i=1,fullinteresting(0) @@ -608,7 +610,7 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d if(.not.pert_2rdm)then call fill_buffer_double(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, variance, norm, mat, buf) else - call fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, variance, norm, mat, buf,fullminilist, coef_fullminilist, fullinteresting(0)) + call fill_buffer_double_rdm(i_generator, sp, h1, h2, bannedOrb, banned, fock_diag_tmp, E0, pt2, variance, norm, mat, buf,fullminilist, coef_fullminilist_rev, fullinteresting(0)) endif end if enddo @@ -616,7 +618,7 @@ subroutine select_singles_and_doubles(i_generator,hole_mask,particle_mask,fock_d enddo deallocate(fullminilist,minilist) if(pert_2rdm)then - deallocate(coef_fullminilist) + deallocate(coef_fullminilist_rev) endif enddo enddo diff --git a/src/cipsi/update_2rdm.irp.f b/src/cipsi/update_2rdm.irp.f index 7ae42ea8..260c48fd 100644 --- a/src/cipsi/update_2rdm.irp.f +++ b/src/cipsi/update_2rdm.irp.f @@ -1,12 +1,12 @@ use bitmasks -subroutine give_2rdm_pert_contrib(det,coef,psi_det_connection,psi_coef_connection,n_det_connection,nkeys,keys,values,sze_buff) +subroutine give_2rdm_pert_contrib(det,coef,psi_det_connection,psi_coef_connection_reverse,n_det_connection,nkeys,keys,values,sze_buff) implicit none integer, intent(in) :: n_det_connection,sze_buff double precision, intent(in) :: coef(N_states) integer(bit_kind), intent(in) :: det(N_int,2) integer(bit_kind), intent(in) :: psi_det_connection(N_int,2,n_det_connection) - double precision, intent(in) :: psi_coef_connection(n_det_connection, N_states) + double precision, intent(in) :: psi_coef_connection_reverse(N_states,n_det_connection) integer, intent(inout) :: keys(4,sze_buff),nkeys double precision, intent(inout) :: values(sze_buff) integer :: i,j @@ -18,24 +18,26 @@ subroutine give_2rdm_pert_contrib(det,coef,psi_det_connection,psi_coef_connectio if(degree.gt.2)cycle contrib = 0.d0 do j = 1, N_states - contrib += state_average_weight(j) * psi_coef_connection(i,j) * phase * coef(j) + contrib += state_average_weight(j) * psi_coef_connection_reverse(j,i) * phase * coef(j) enddo ! case of single excitations if(degree == 1)then - if (nkeys+ 2 * elec_alpha_num .ge. sze_buff)then - call update_rdms(nkeys,keys,values,sze_buff) + if (nkeys + 6 * elec_alpha_num .ge. sze_buff)then + call update_keys_values(keys,values,nkeys,n_orb_pert_rdm,pert_2rdm_provider,pert_2rdm_lock) nkeys = 0 endif call update_buffer_single_exc_rdm(det,psi_det_connection(1,1,i),exc,phase,contrib,nkeys,keys,values,sze_buff) else - ! case of double excitations - if (nkeys+ 4 .ge. sze_buff)then - call update_rdms(nkeys,keys,values,sze_buff) - nkeys = 0 - endif - call update_buffer_double_exc_rdm(exc,phase,contrib,nkeys,keys,values,sze_buff) + !! case of double excitations + ! if (nkeys + 4 .ge. sze_buff)then + ! call update_keys_values(keys,values,nkeys,n_orb_pert_rdm,pert_2rdm_provider,pert_2rdm_lock) + ! nkeys = 0 + ! endif + ! call update_buffer_double_exc_rdm(exc,phase,contrib,nkeys,keys,values,sze_buff) endif enddo +!call update_keys_values(keys,values,nkeys,n_orb_pert_rdm,pert_2rdm_provider,pert_2rdm_lock) +!nkeys = 0 end @@ -49,7 +51,81 @@ subroutine update_buffer_single_exc_rdm(det1,det2,exc,phase,contrib,nkeys,keys,v integer, intent(inout) :: nkeys, keys(4,sze_buff) double precision, intent(inout):: values(sze_buff) + integer :: occ(N_int*bit_kind_size,2) + integer :: n_occ_ab(2),ispin,other_spin + integer :: h1,h2,p1,p2,i + call bitstring_to_list_ab(det1, occ, n_occ_ab, N_int) + + if (exc(0,1,1) == 1) then + ! Mono alpha + h1 = exc(1,1,1) + p1 = exc(1,2,1) + ispin = 1 + other_spin = 2 + else + ! Mono beta + h1 = exc(1,1,2) + p1 = exc(1,2,2) + ispin = 2 + other_spin = 1 + endif + if(list_orb_reverse_pert_rdm(h1).lt.0)return + h1 = list_orb_reverse_pert_rdm(h1) + if(list_orb_reverse_pert_rdm(p1).lt.0)return + p1 = list_orb_reverse_pert_rdm(p1) + !update the alpha/beta part + do i = 1, n_occ_ab(other_spin) + h2 = occ(i,other_spin) + if(list_orb_reverse_pert_rdm(h2).lt.0)return + h2 = list_orb_reverse_pert_rdm(h2) + nkeys += 1 + values(nkeys) = 0.5d0 * contrib * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = h2 + nkeys += 1 + values(nkeys) = 0.5d0 * contrib * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = h2 + keys(4,nkeys) = p1 + enddo + !update the same spin part +!do i = 1, n_occ_ab(ispin) +! h2 = occ(i,ispin) +! if(list_orb_reverse_pert_rdm(h2).lt.0)return +! h2 = list_orb_reverse_pert_rdm(h2) + +! nkeys += 1 +! values(nkeys) = 0.5d0 * contrib * phase +! keys(1,nkeys) = h1 +! keys(2,nkeys) = h2 +! keys(3,nkeys) = p1 +! keys(4,nkeys) = h2 + +! nkeys += 1 +! values(nkeys) = - 0.5d0 * contrib * phase +! keys(1,nkeys) = h1 +! keys(2,nkeys) = h2 +! keys(3,nkeys) = h2 +! keys(4,nkeys) = p1 +! +! nkeys += 1 +! values(nkeys) = 0.5d0 * contrib * phase +! keys(1,nkeys) = h2 +! keys(2,nkeys) = h1 +! keys(3,nkeys) = h2 +! keys(4,nkeys) = p1 + +! nkeys += 1 +! values(nkeys) = - 0.5d0 * contrib * phase +! keys(1,nkeys) = h2 +! keys(2,nkeys) = h1 +! keys(3,nkeys) = p1 +! keys(4,nkeys) = h2 +!enddo end @@ -60,21 +136,88 @@ subroutine update_buffer_double_exc_rdm(exc,phase,contrib,nkeys,keys,values,sze_ double precision,intent(in) :: phase, contrib integer, intent(inout) :: nkeys, keys(4,sze_buff) double precision, intent(inout):: values(sze_buff) + integer :: h1,h2,p1,p2 + if (exc(0,1,1) == 1) then + ! Double alpha/beta + h1 = exc(1,1,1) + h2 = exc(1,1,2) + p1 = exc(1,2,1) + p2 = exc(1,2,2) + ! check if the orbitals involved are within the orbital range + if(list_orb_reverse_pert_rdm(h1).lt.0)return + h1 = list_orb_reverse_pert_rdm(h1) + if(list_orb_reverse_pert_rdm(h2).lt.0)return + h2 = list_orb_reverse_pert_rdm(h2) + if(list_orb_reverse_pert_rdm(p1).lt.0)return + p1 = list_orb_reverse_pert_rdm(p1) + if(list_orb_reverse_pert_rdm(p2).lt.0)return + p2 = list_orb_reverse_pert_rdm(p2) + nkeys += 1 + values(nkeys) = 0.5d0 * contrib * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + nkeys += 1 + values(nkeys) = 0.5d0 * contrib * phase + keys(1,nkeys) = p1 + keys(2,nkeys) = p2 + keys(3,nkeys) = h1 + keys(4,nkeys) = h2 + else + if (exc(0,1,1) == 2) then + ! Double alpha/alpha + h1 = exc(1,1,1) + h2 = exc(2,1,1) + p1 = exc(1,2,1) + p2 = exc(2,2,1) + else if (exc(0,1,2) == 2) then + ! Double beta + h1 = exc(1,1,2) + h2 = exc(2,1,2) + p1 = exc(1,2,2) + p2 = exc(2,2,2) + endif + ! check if the orbitals involved are within the orbital range + if(list_orb_reverse_pert_rdm(h1).lt.0)return + h1 = list_orb_reverse_pert_rdm(h1) + if(list_orb_reverse_pert_rdm(h2).lt.0)return + h2 = list_orb_reverse_pert_rdm(h2) + if(list_orb_reverse_pert_rdm(p1).lt.0)return + p1 = list_orb_reverse_pert_rdm(p1) + if(list_orb_reverse_pert_rdm(p2).lt.0)return + p2 = list_orb_reverse_pert_rdm(p2) + nkeys += 1 + values(nkeys) = 0.5d0 * contrib * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + + nkeys += 1 + values(nkeys) = - 0.5d0 * contrib * phase + keys(1,nkeys) = h1 + keys(2,nkeys) = h2 + keys(3,nkeys) = p2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = 0.5d0 * contrib * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p2 + keys(4,nkeys) = p1 + + nkeys += 1 + values(nkeys) = - 0.5d0 * contrib * phase + keys(1,nkeys) = h2 + keys(2,nkeys) = h1 + keys(3,nkeys) = p1 + keys(4,nkeys) = p2 + endif + end -subroutine update_rdms(nkeys,keys,values,sze_buff) - implicit none - integer, intent(in) :: nkeys, keys(4,sze_buff),sze_buff - double precision, intent(in) :: values(sze_buff) - integer :: i,h1,h2,p1,p2 - do i = 1, nkeys - h1 = keys(1,i) - h2 = keys(2,i) - p1 = keys(3,i) - p2 = keys(4,i) - pert_2rdm_provider(h1,h2,p1,p2) += values(i) - enddo -end From 33b38b5d78d598e5710252f0a41b97a01f2ec82d Mon Sep 17 00:00:00 2001 From: Emmanuel Giner LCT Date: Mon, 15 Jul 2019 15:47:48 +0200 Subject: [PATCH 55/59] fixed generators problem for cisd in casscf --- src/casscf/cisd_routine.irp.f | 4 ++++ src/casscf/test_pert_2rdm.irp.f | 2 +- src/determinants/h_apply.irp.f | 3 +++ 3 files changed, 8 insertions(+), 1 deletion(-) diff --git a/src/casscf/cisd_routine.irp.f b/src/casscf/cisd_routine.irp.f index a8a30747..86f56fc6 100644 --- a/src/casscf/cisd_routine.irp.f +++ b/src/casscf/cisd_routine.irp.f @@ -6,6 +6,10 @@ subroutine cisd_scf_iteration(converged,iteration,energy,thr) double precision, intent(out) :: energy converged = .False. call only_act_bitmask + N_det = N_det_generators + psi_coef = psi_coef_generators + psi_det = psi_det_generators + touch N_det psi_coef psi_det call run_cisd call change_orb_cisd(converged,iteration,energy,thr) end diff --git a/src/casscf/test_pert_2rdm.irp.f b/src/casscf/test_pert_2rdm.irp.f index 89d7bc8a..7c40de0f 100644 --- a/src/casscf/test_pert_2rdm.irp.f +++ b/src/casscf/test_pert_2rdm.irp.f @@ -2,7 +2,7 @@ program test_pert_2rdm implicit none read_wf = .True. touch read_wf - call get_pert_2rdm +!call get_pert_2rdm integer :: i,j,k,l,ii,jj,kk,ll double precision :: accu , get_two_e_integral, integral accu = 0.d0 diff --git a/src/determinants/h_apply.irp.f b/src/determinants/h_apply.irp.f index f0d4d1c9..676f2fd0 100644 --- a/src/determinants/h_apply.irp.f +++ b/src/determinants/h_apply.irp.f @@ -182,6 +182,9 @@ subroutine copy_H_apply_buffer_to_wf ASSERT (sum(popcnt(psi_det(:,2,i+N_det_old))) == elec_beta_num ) enddo do k=1,N_states + print*,"H_apply_buffer(j)%N_det",H_apply_buffer(j)%N_det + print*,'N_det_old = ',N_det_old + print*,'size(psi_coef,1)', size(psi_coef,1) do i=1,H_apply_buffer(j)%N_det psi_coef(i+N_det_old,k) = H_apply_buffer(j)%coef(i,k) enddo From dfd5f25af7ceddf11051cfb5f8958fb27a1cc98e Mon Sep 17 00:00:00 2001 From: Emmanuel Giner LCT Date: Tue, 16 Jul 2019 19:51:53 +0200 Subject: [PATCH 56/59] put the openmp 2rdm --- src/casscf/densities.irp.f | 2 +- src/determinants/h_apply.irp.f | 3 --- src/generators_fluid/generators_hf.irp.f | 2 +- 3 files changed, 2 insertions(+), 5 deletions(-) diff --git a/src/casscf/densities.irp.f b/src/casscf/densities.irp.f index 88c9021d..fabb4d34 100644 --- a/src/casscf/densities.irp.f +++ b/src/casscf/densities.irp.f @@ -56,7 +56,7 @@ BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ] uu = list_act(u) do t = 1, n_act_orb tt = list_act(t) - P0tuvx(t,u,v,x) = state_av_act_two_rdm_spin_trace_mo(t,v,u,x) + P0tuvx(t,u,v,x) = state_av_act_two_rdm_openmp_spin_trace_mo(t,v,u,x) enddo enddo enddo diff --git a/src/determinants/h_apply.irp.f b/src/determinants/h_apply.irp.f index 676f2fd0..f0d4d1c9 100644 --- a/src/determinants/h_apply.irp.f +++ b/src/determinants/h_apply.irp.f @@ -182,9 +182,6 @@ subroutine copy_H_apply_buffer_to_wf ASSERT (sum(popcnt(psi_det(:,2,i+N_det_old))) == elec_beta_num ) enddo do k=1,N_states - print*,"H_apply_buffer(j)%N_det",H_apply_buffer(j)%N_det - print*,'N_det_old = ',N_det_old - print*,'size(psi_coef,1)', size(psi_coef,1) do i=1,H_apply_buffer(j)%N_det psi_coef(i+N_det_old,k) = H_apply_buffer(j)%coef(i,k) enddo diff --git a/src/generators_fluid/generators_hf.irp.f b/src/generators_fluid/generators_hf.irp.f index 29e2d365..d4d2e728 100644 --- a/src/generators_fluid/generators_hf.irp.f +++ b/src/generators_fluid/generators_hf.irp.f @@ -34,7 +34,7 @@ END_PROVIDER end do psi_det_generators_HF(:,:,1) = psi_det(:,:,j) - psi_coef_generators_HF(1,:) = psi_coef_generators_HF(j,:) + psi_coef_generators_HF(1,:) = 1.d0 END_PROVIDER From bee191ee2887f36c3c021a5a97a1bfe90cae46ff Mon Sep 17 00:00:00 2001 From: Emmanuel Giner LCT Date: Fri, 30 Aug 2019 16:30:50 +0200 Subject: [PATCH 57/59] working on casscf --- src/casscf/casscf.irp.f | 2 -- src/casscf/cipsi_routines.irp.f | 3 +++ src/casscf/cisd_routine.irp.f | 16 ++++++++++++++++ src/casscf/densities.irp.f | 3 ++- 4 files changed, 21 insertions(+), 3 deletions(-) diff --git a/src/casscf/casscf.irp.f b/src/casscf/casscf.irp.f index c98bfc44..31baec18 100644 --- a/src/casscf/casscf.irp.f +++ b/src/casscf/casscf.irp.f @@ -78,8 +78,6 @@ program casscf enddo endif endif - generators_type = "CAS" - touch generators_type read_wf = .False. touch read_wf pt2_max = 0.015d0 diff --git a/src/casscf/cipsi_routines.irp.f b/src/casscf/cipsi_routines.irp.f index 58e95574..272a7116 100644 --- a/src/casscf/cipsi_routines.irp.f +++ b/src/casscf/cipsi_routines.irp.f @@ -19,6 +19,9 @@ subroutine run_cipsi_scf print*,'' call write_int(6,iteration,'CI STEP OF THE ITERATION = ') call write_double(6,pt2_max,'PT2 MAX = ') + !call cisd_guess_wf + generators_type = "CAS" + touch generators_type call run_stochastic_cipsi call change_orb_cipsi(converged,iteration,energy) if(iteration.gt.n_it_scf_max.and..not.converged)then diff --git a/src/casscf/cisd_routine.irp.f b/src/casscf/cisd_routine.irp.f index 86f56fc6..b7edd7c9 100644 --- a/src/casscf/cisd_routine.irp.f +++ b/src/casscf/cisd_routine.irp.f @@ -14,6 +14,22 @@ subroutine cisd_scf_iteration(converged,iteration,energy,thr) call change_orb_cisd(converged,iteration,energy,thr) end + +subroutine cisd_guess_wf + implicit none + call only_act_bitmask + N_det = N_det_generators + psi_coef = psi_coef_generators + psi_det = psi_det_generators + touch N_det psi_coef psi_det + generators_type = "HF" + touch generators_type + call run_cisd + touch N_det psi_coef psi_det psi_coef_sorted psi_det_sorted +end + + + subroutine change_orb_cisd(converged,iteration,energy,thr) implicit none double precision, intent(in) :: thr diff --git a/src/casscf/densities.irp.f b/src/casscf/densities.irp.f index fabb4d34..292067b4 100644 --- a/src/casscf/densities.irp.f +++ b/src/casscf/densities.irp.f @@ -56,7 +56,8 @@ BEGIN_PROVIDER [real*8, P0tuvx, (n_act_orb,n_act_orb,n_act_orb,n_act_orb) ] uu = list_act(u) do t = 1, n_act_orb tt = list_act(t) - P0tuvx(t,u,v,x) = state_av_act_two_rdm_openmp_spin_trace_mo(t,v,u,x) +! P0tuvx(t,u,v,x) = state_av_act_two_rdm_openmp_spin_trace_mo(t,v,u,x) + P0tuvx(t,u,v,x) = state_av_act_two_rdm_spin_trace_mo(t,v,u,x) enddo enddo enddo From 2e32cd2267c66ded516c5b4babced4d256b7ccb6 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner LCT Date: Fri, 30 Aug 2019 20:00:29 +0200 Subject: [PATCH 58/59] changed some radiis for DFT --- .../integration_radial.irp.f | 2 +- src/dft_utils_in_r/mo_in_r.irp.f | 1 + src/nuclei/atomic_radii.irp.f | 53 ++++++++++++++++++- 3 files changed, 54 insertions(+), 2 deletions(-) diff --git a/src/becke_numerical_grid/integration_radial.irp.f b/src/becke_numerical_grid/integration_radial.irp.f index c1add0cf..44c83070 100644 --- a/src/becke_numerical_grid/integration_radial.irp.f +++ b/src/becke_numerical_grid/integration_radial.irp.f @@ -64,7 +64,7 @@ enddo ! Ga-Kr - do i = 31, 36 + do i = 31, 100 alpha_knowles(i) = 7.d0 enddo diff --git a/src/dft_utils_in_r/mo_in_r.irp.f b/src/dft_utils_in_r/mo_in_r.irp.f index 60cd59f2..bfcc8abb 100644 --- a/src/dft_utils_in_r/mo_in_r.irp.f +++ b/src/dft_utils_in_r/mo_in_r.irp.f @@ -32,6 +32,7 @@ ! k = 1 : x, k= 2, y, k 3, z END_DOC integer :: m + print*,'mo_num,n_points_final_grid',mo_num,n_points_final_grid mos_grad_in_r_array = 0.d0 do m=1,3 call dgemm('N','N',mo_num,n_points_final_grid,ao_num,1.d0,mo_coef_transp,mo_num,aos_grad_in_r_array(1,1,m),ao_num,0.d0,mos_grad_in_r_array(1,1,m),mo_num) diff --git a/src/nuclei/atomic_radii.irp.f b/src/nuclei/atomic_radii.irp.f index 439b5cec..c189effd 100644 --- a/src/nuclei/atomic_radii.irp.f +++ b/src/nuclei/atomic_radii.irp.f @@ -50,7 +50,58 @@ BEGIN_PROVIDER [ double precision, slater_bragg_radii, (0:100)] slater_bragg_radii(33) = 1.15d0 slater_bragg_radii(34) = 1.15d0 slater_bragg_radii(35) = 1.15d0 - slater_bragg_radii(36) = 1.15d0 + slater_bragg_radii(36) = 1.10d0 + + slater_bragg_radii(37) = 2.35d0 + slater_bragg_radii(38) = 2.00d0 + slater_bragg_radii(39) = 1.80d0 + slater_bragg_radii(40) = 1.55d0 + slater_bragg_radii(41) = 1.45d0 + slater_bragg_radii(42) = 1.45d0 + slater_bragg_radii(43) = 1.35d0 + slater_bragg_radii(44) = 1.30d0 + slater_bragg_radii(45) = 1.35d0 + slater_bragg_radii(46) = 1.40d0 + slater_bragg_radii(47) = 1.60d0 + slater_bragg_radii(48) = 1.55d0 + slater_bragg_radii(49) = 1.55d0 + slater_bragg_radii(50) = 1.45d0 + slater_bragg_radii(51) = 1.45d0 + slater_bragg_radii(52) = 1.40d0 + slater_bragg_radii(53) = 1.40d0 + slater_bragg_radii(54) = 1.40d0 + slater_bragg_radii(55) = 2.60d0 + slater_bragg_radii(56) = 2.15d0 + slater_bragg_radii(57) = 1.95d0 + slater_bragg_radii(58) = 1.85d0 + slater_bragg_radii(59) = 1.85d0 + slater_bragg_radii(60) = 1.85d0 + slater_bragg_radii(61) = 1.85d0 + slater_bragg_radii(62) = 1.85d0 + slater_bragg_radii(63) = 1.85d0 + slater_bragg_radii(64) = 1.80d0 + slater_bragg_radii(65) = 1.75d0 + slater_bragg_radii(66) = 1.75d0 + slater_bragg_radii(67) = 1.75d0 + slater_bragg_radii(68) = 1.75d0 + slater_bragg_radii(69) = 1.75d0 + slater_bragg_radii(70) = 1.75d0 + slater_bragg_radii(71) = 1.75d0 + slater_bragg_radii(72) = 1.55d0 + slater_bragg_radii(73) = 1.45d0 + slater_bragg_radii(74) = 1.35d0 + slater_bragg_radii(75) = 1.30d0 + slater_bragg_radii(76) = 1.30d0 + slater_bragg_radii(77) = 1.35d0 + slater_bragg_radii(78) = 1.35d0 + slater_bragg_radii(79) = 1.35d0 + slater_bragg_radii(80) = 1.50d0 + slater_bragg_radii(81) = 1.90d0 + slater_bragg_radii(82) = 1.75d0 + slater_bragg_radii(83) = 1.60d0 + slater_bragg_radii(84) = 1.90d0 + slater_bragg_radii(85) = 1.50d0 + slater_bragg_radii(86) = 1.50d0 END_PROVIDER From bfe52ed56f9bf1f90a8e8acb04f1c39abe038c37 Mon Sep 17 00:00:00 2001 From: Emmanuel Giner LCT Date: Thu, 26 Sep 2019 17:03:47 +0200 Subject: [PATCH 59/59] fixed bug in HF_exchange --- src/dft_one_e/e_xc_general.irp.f | 2 +- src/dft_one_e/pot_general.irp.f | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/dft_one_e/e_xc_general.irp.f b/src/dft_one_e/e_xc_general.irp.f index dc8b9d9a..fc9f9fd2 100644 --- a/src/dft_one_e/e_xc_general.irp.f +++ b/src/dft_one_e/e_xc_general.irp.f @@ -15,7 +15,7 @@ prefix = "" for f in functionals: print """ %sif (trim(exchange_functional) == '%s') then - energy_x = energy_x_%s"""%(prefix, f, f) + energy_x = (1.d0 - HF_exchange ) * energy_x_%s"""%(prefix, f, f) prefix = "else " print """ else diff --git a/src/dft_one_e/pot_general.irp.f b/src/dft_one_e/pot_general.irp.f index 237af8c0..2f45a464 100644 --- a/src/dft_one_e/pot_general.irp.f +++ b/src/dft_one_e/pot_general.irp.f @@ -17,8 +17,8 @@ prefix = "" for f in functionals: print """ %sif (trim(exchange_functional) == '%s') then - potential_x_alpha_ao = potential_x_alpha_ao_%s - potential_x_beta_ao = potential_x_beta_ao_%s"""%(prefix, f, f, f) + potential_x_alpha_ao = ( 1.d0 - HF_exchange ) * potential_x_alpha_ao_%s + potential_x_beta_ao = ( 1.d0 - HF_exchange ) * potential_x_beta_ao_%s"""%(prefix, f, f, f) prefix = "else " print """ else