fitting ok

ocaml/Input.ml

@@ -2,6 +2,7 @@ open Qputils;;
 open Qptypes;;
 
 include Input_ao_basis;;
+include Input_ao_extra_basis;;
 include Input_bitmasks;;
 include Input_determinants_by_hand;;
 include Input_electrons;;

plugins/local/ao_extra_basis/EZFIO.cfg

@@ -1,9 +1,3 @@
-[ao_extra_center]
-type: double precision
-doc: parameter for off-centering s functions to mimick p functions
-interface: ezfio, provider
-default:0.01
-
 [ao_extra_basis]
 type: character*(256)
 doc: Name of the |ao_extra| basis set

plugins/local/ao_extra_basis/fit_1s_basis.irp.f

@@ -1,8 +1,24 @@
 program fit_1s_basis
  implicit none
  provide lmax_too_big
- integer :: i
+ integer :: i,j
-! print*,'n_func_tot', n_func_tot
+ print*,'////////////////////////////////////////////////////'
- provide  new_nucl_coord
+ print*,'////////////////////////////////////////////////////'
- 
+ print*,'Fitting the original basis set on uncontracted s only functions '
+ print*,'WARNING :: works for now with only P functions at most !!'
+ print*,'WARNING :: otherwise it will stop '
+ print*,'Writting the results in the extra_nuclei and ao_extra_basis folders of EZFIO'
+ print*,'New number of atomic functions : '
+ print*,'n_func_tot = ',n_func_tot
+ call ezfio_set_extra_nuclei_extra_nucl_num(new_nucl_num)
+ call ezfio_set_extra_nuclei_extra_nucl_charge(new_nucl_charge_1s)
+ call ezfio_set_extra_nuclei_extra_nucl_coord(new_nucl_coord_1s)
+ call ezfio_set_extra_nuclei_extra_nucl_label(new_nucl_label_1s)
+ call ezfio_set_ao_extra_basis_ao_extra_num(n_func_tot)
+ call ezfio_set_ao_extra_basis_ao_extra_nucl(new_ao_nucl_1s)
+ call ezfio_set_ao_extra_basis_ao_extra_prim_num(new_ao_prim_num_1s)
+ call ezfio_set_ao_extra_basis_ao_extra_coef(new_ao_coef_1s)
+ call ezfio_set_ao_extra_basis_ao_extra_expo(new_ao_expo_1s)
+ call ezfio_set_ao_extra_basis_ao_extra_power(new_ao_power_1s)
 end
+

plugins/local/ao_extra_basis/prov_fit_1s.irp.f

@@ -1,3 +1,8 @@
+BEGIN_PROVIDER [ double precision, ao_extra_center]
+ implicit none
+ ao_extra_center = 0.01d0
+END_PROVIDER 
+
  BEGIN_PROVIDER [ integer, n_func_tot]
  implicit none
  BEGIN_DOC
@@ -61,6 +66,7 @@ END_PROVIDER
    n_2p_func_tot += ao_prim_num(i) * 2
   endif
  enddo
+ print*,'n_2p_func_tot = ',n_2p_func_tot
 END_PROVIDER 
 
 BEGIN_PROVIDER [ integer, list_2p_functions, (n_2p_func_orig)]
@@ -80,80 +86,167 @@ END_PROVIDER
 
 BEGIN_PROVIDER [ integer, new_nucl_num]
  implicit none
- new_nucl_num = n_func_tot
+ new_nucl_num = nucl_num + n_2p_func_tot
+ print*,'new_nucl_num = ',new_nucl_num
 END_PROVIDER 
 
-BEGIN_PROVIDER [ double precision, new_ao_expo_1s , (n_func_tot) ]
+BEGIN_PROVIDER [ character*(32), new_nucl_label_1s , (new_nucl_num) ]
  implicit none
- integer :: i,j,ii,i_ao,k
+ integer :: i
- k = 0
+ do i = 1, nucl_num 
- do i = 1, nucl_num
+  new_nucl_label_1s(i) = nucl_label(i)
-  do ii = 1, Nucl_N_Aos(i)
+ enddo
-   i_ao = nucl_aos_transposed(ii,i)
+ do i = nucl_num+1,new_nucl_num
-   if(ao_l(i_ao)==0)then
+  new_nucl_label_1s(i) = "X"
-    do j = 1, ao_prim_num(i_ao)
-     k+=1
-     new_ao_expo_1s(k)= ao_expo(i_ao,j)
-    enddo
-   else if(ao_l(i_ao)==1)then
-    ! for 'p' functions 
-    ! you replace the function by 2 functions 's' 
-    do j = 1, ao_prim_num(i_ao)
-     k+=1
-     new_ao_expo_1s(k)= ao_expo(i_ao,j)
-     k+=1
-     new_ao_expo_1s(k)= ao_expo(i_ao,j)
-    enddo
-   else 
-    print*,'WARNING ! Lmax value not implemented yet !'
-    print*,'stopping ...'
-    stop
-   endif
-  enddo
  enddo
- if(k.ne.n_func_tot)then
-  print*,'pb !!! k NE n_func_tot !!'
-  print*,k,n_func_tot
-  stop
- endif
-
 END_PROVIDER 
-
+ 
-BEGIN_PROVIDER [ double precision, new_nucl_coord, (3,new_nucl_num)]
+ BEGIN_PROVIDER [ double precision,  new_nucl_coord_1s, (new_nucl_num,3)]
  implicit none
- integer :: i,ii,j,i_ao,k
+ integer :: i,j
- k = 0
+ do i = 1, new_nucl_num
+  new_nucl_coord_1s(i,1:3) = new_nucl_coord_1s_transp(1:3,i)
+ enddo
+ END_PROVIDER 
+
+ BEGIN_PROVIDER [ double precision, new_nucl_coord_1s_transp, (3,new_nucl_num)]
+&BEGIN_PROVIDER [ double precision, new_nucl_charge_1s, (new_nucl_num)]
+ implicit none
+ BEGIN_DOC
+! the real atoms are located in the first nucl_num entries 
+! 
+! then the fictious atoms are located after
+ END_DOC
+ integer :: i,ii,j,i_ao,k,n_ao
+ integer :: return_xyz_int,power(3),good_i
+ new_nucl_charge_1s = 0.d0
+ do i = 1, nucl_num
+  new_nucl_coord_1s_transp(1:3,i) = nucl_coord_transp(1:3,i)
+  new_nucl_charge_1s(i) = nucl_charge(i)
+ enddo
+ k = nucl_num
  do i = 1, nucl_num
   do ii = 1, Nucl_N_Aos(i)
    i_ao = nucl_aos_transposed(ii,i)
-   if(ao_l(i_ao)==0)then
+   if(ao_l(i_ao)==1)then
-    do j = 1, ao_prim_num(i_ao)
-     k+=1
-     new_nucl_coord(1:3,k)=nucl_coord_transp(1:3,i)
-    enddo
-   else if(ao_l(i_ao)==1)then
     ! split the function into 2 s functions 
     ! one is centered in R_x + d 
+    power(1:3) = ao_power(i_ao,1:3)
+    good_i = return_xyz_int(power)
     do j = 1, ao_prim_num(i_ao)
      k+=1
-     new_nucl_coord(2:3,k)= nucl_coord_transp(2:3,i)
+     new_nucl_coord_1s_transp(1:3,k)= nucl_coord_transp(1:3,i)
-     new_nucl_coord(1,k)= nucl_coord_transp(1,i)+ao_extra_center
+     new_nucl_coord_1s_transp(good_i,k)+= ao_extra_center
+     new_nucl_charge_1s(k) = 0.d0
      k+=1
      ! one is centered in R_x - d 
-     new_nucl_coord(2:3,k)= nucl_coord_transp(2:3,i)
+     new_nucl_coord_1s_transp(1:3,k)= nucl_coord_transp(1:3,i)
-     new_nucl_coord(1,k)= nucl_coord_transp(1,i)-ao_extra_center
+     new_nucl_coord_1s_transp(good_i,k)-= ao_extra_center
+     new_nucl_charge_1s(k) = 0.d0
     enddo
-   else 
+   else if(ao_l(i_ao).gt.1)then
     print*,'WARNING ! Lmax value not implemented yet !'
     print*,'stopping ...'
     stop
    endif
   enddo
  enddo
- if(k.ne.n_func_tot)then
-  print*,'pb !!! k NE n_func_tot !!'
-  print*,k,n_func_tot
-  stop
- endif
 
 END_PROVIDER 
+
+ BEGIN_PROVIDER [ integer, new_n_AOs_max]
+ implicit none
+ new_n_AOs_max = ao_prim_num_max * n_AOs_max
+ 
+ END_PROVIDER 
+
+
+ BEGIN_PROVIDER [ integer, new_Nucl_N_Aos, (new_nucl_num)]
+&BEGIN_PROVIDER [ integer, new_nucl_aos_transposed, (new_n_AOs_max,new_nucl_num) ]
+&BEGIN_PROVIDER [ double precision, new_ao_expo_1s , (n_func_tot) ]
+&BEGIN_PROVIDER [ integer, new_ao_nucl_1s, (n_func_tot)]
+ implicit none
+ integer :: i,j,ii,i_ao,n_func,n_func_total,n_nucl
+ double precision :: coef
+ n_func_total = 0
+ do i = 1, nucl_num
+  n_func = 0
+  do ii = 1, Nucl_N_Aos(i)
+   i_ao = nucl_aos_transposed(ii,i)
+   if(ao_l(i_ao)==0)then
+    do j = 1, ao_prim_num(i_ao)
+     coef= ao_expo(i_ao,j)
+     n_func_total += 1
+     n_func +=1
+     new_nucl_aos_transposed(n_func,i) = n_func_total
+     new_ao_expo_1s(n_func_total) = coef
+     new_ao_nucl_1s(n_func_total) = i
+    enddo
+   endif
+  enddo
+  new_Nucl_N_Aos(i) = n_func
+ enddo
+ n_nucl=nucl_num
+ do i = 1, nucl_num
+  do ii = 1, Nucl_N_Aos(i)
+   i_ao = nucl_aos_transposed(ii,i)
+   if(ao_l(i_ao)==1)then
+    do j = 1, ao_prim_num(i_ao)
+     coef= ao_expo(i_ao,j)
+     n_func_total+=1
+     n_nucl +=1
+     new_nucl_aos_transposed(1,n_nucl) = n_func_total
+     new_ao_expo_1s(n_func_total) = coef
+     new_Nucl_N_Aos(n_nucl)=1
+     new_ao_nucl_1s(n_func_total) = n_nucl
+
+     n_func_total+=1
+     n_nucl +=1
+     new_nucl_aos_transposed(1,n_nucl) = n_func_total
+     new_ao_expo_1s(n_func_total) = coef
+     new_Nucl_N_Aos(n_nucl)=1
+     new_ao_nucl_1s(n_func_total) = n_nucl
+    enddo
+   endif
+  enddo
+ enddo
+
+END_PROVIDER 
+
+BEGIN_PROVIDER [ double precision, new_ao_coef_1s , (n_func_tot) ]
+  implicit none
+ integer :: i
+  BEGIN_DOC
+! Primitive coefficients, read from input. Those should not be used directly, as the MOs are expressed on the basis of **normalized** AOs.
+  END_DOC
+  do i = 1, n_func_tot
+   new_ao_coef_1s(i) = 1.d0
+  enddo
+END_PROVIDER 
+
+BEGIN_PROVIDER [ integer, new_ao_prim_num_1s, (n_func_tot)]
+ implicit none
+ integer :: i
+ do i = 1, n_func_tot
+  new_ao_prim_num_1s(i) = 1
+ enddo
+END_PROVIDER 
+
+BEGIN_PROVIDER [integer, new_ao_power_1s, (n_func_tot,3)]
+ implicit none
+ new_ao_power_1s = 0
+END_PROVIDER 
+
+integer function return_xyz_int(power)
+ implicit none
+ integer,intent(in) :: power(3)
+ if(power(1) == 1 .and. power(2) ==0 .and. power(3) ==0)then
+  return_xyz_int = 1
+ else if (power(2) == 1 .and. power(1) ==0 .and. power(3) ==0)then
+  return_xyz_int = 2
+ else if (power(3) == 1 .and. power(1) ==0 .and. power(1) ==0)then
+  return_xyz_int = 3
+ else 
+  return_xyz_int = -1000
+ endif
+end

plugins/local/ao_extra_basis/qp_copy_extra_basis_to_usual_basis

@@ -0,0 +1,59 @@
+#!/bin/bash 
+# specify the QP folder 
+QP=$QP_ROOT
+dir=${QP}
+# sourcing the quantum_package.rc file
+. ${QP}/quantum_package.rc
+EZFIO_extra=${1%/}
+EZFIO_target=${2%/}
+
+
+
+echo "********** SCRIPT TO COPY DATA FROM EZFIO TO ANOTHER *********"
+echo "Extracting data from "$EZFIO_extra 
+echo "and Copying data to  "$EZFIO_target
+
+### COPYING ALL DATA FROM $EZFIO_extra/nuclei/ to ${EZFIO_target}/extra_nuclei/
+echo "COPYING ALL DATA FROM "$EZFIO_extra"/extra_nuclei/ to "${EZFIO_target}"/nuclei/"
+direxists=false
+if [ -d ${EZFIO_target}/extra_nuclei/ ] ; then
+ direxists=true
+ echo "The directory extra_nuclei exists"
+ else
+ echo "PB !!"
+ direxists=false
+ mkdir ${EZFIO_target}/extra_nuclei/
+fi
+data=`\ls $EZFIO_extra/extra_nuclei/`
+for i in $data
+do
+ echo $i
+ newfile=`echo $i | sed 's/extra_nucl/nucl/g' `
+ echo $newfile
+ cp ${EZFIO_extra}/extra_nuclei/$i ${EZFIO_target}/nuclei/$newfile
+done
+
+### COPYING ALL DATA FROM $EZFIO_extra/ao_basis/ to ${EZFIO_target}/ao_extra_basis/
+direxists=false
+if [ -d ${EZFIO_target}/ao_extra_basis/ ] ; then
+ direxists=true
+ echo "The directory exists ao_extra_basis"
+ else
+ echo "PB !!"
+ direxists=false
+ mkdir ${EZFIO_target}/ao_extra_basis/
+fi
+echo "COPYING ALL DATA FROM "$EZFIO_extra"/ao_basis/ to "${EZFIO_target}"/ao_extra_basis/"
+data=`\ls $EZFIO_extra/ao_extra_basis/`
+for i in $data
+do
+ echo $i
+ newfile=`echo $i | sed 's/ao_extra/ao/g' `
+ echo $newfile
+ cp ${EZFIO_extra}/ao_extra_basis/$i ${EZFIO_target}/ao_basis/$newfile
+done
+#i=primitives_normalized
+#newfile=primitives_normalized_extra
+#cp ${EZFIO_extra}/ao_basis/$i ${EZFIO_target}/ao_extra_basis/$newfile
+
+

scripts/ezfio_interface/qp_edit_template

@@ -17,6 +17,7 @@ This file is automatically generated by
 (** Keywords used to define input sections *)
 type keyword =
 | Ao_basis
+| Ao_extra_basis
 | Determinants_by_hand
 | Electrons
 | Mo_basis
@@ -27,6 +28,7 @@ type keyword =
 
 let keyword_to_string = function
 | Ao_basis              -> "AO basis"
+| Ao_extra_basis              -> "AO extra_basis"
 | Determinants_by_hand  -> "Determinants_by_hand"
 | Electrons             -> "Electrons"
 | Mo_basis              -> "MO basis"
@@ -76,6 +78,8 @@ let get s =
            f Electrons.(read, to_rst)
          | Nuclei_by_hand ->
            f Nuclei_by_hand.(read, to_rst)
+         | Ao_extra_basis ->
+           f Ao_extra_basis.(read, to_rst)
          | Ao_basis ->
            f Ao_basis.(read, to_rst)
          | Determinants_by_hand ->
@@ -123,6 +127,7 @@ let set str s =
         | Determinants_by_hand     -> write Determinants_by_hand.(of_rst, write ~force:false) s
         | Nuclei_by_hand           -> write Nuclei_by_hand.(of_rst, write) s
         | Ao_basis         -> () (* TODO *)
+        | Ao_extra_basis         -> () (* TODO *)
         | Mo_basis         -> () (* TODO *)
     end
 
@@ -199,6 +204,22 @@ let run check_only ?ndet ?state ?read ?write ezfio_filename =
     | _ -> ()
   end;
 
+  (* Reorder extra basis set *)
+  begin
+    match Input.Ao_extra_basis.read() with
+    | Some aos ->
+        let ordering = Input.Ao_extra_basis.ordering aos in
+        let test = Array.copy ordering in
+        Array.sort compare test ;
+        if test <> ordering then
+        begin
+          Printf.eprintf "Warning: Basis set is not properly ordered. Redordering.\n";
+          let new_aos = Input.Ao_extra_basis.reorder aos in
+          Input.Ao_extra_basis.write new_aos;
+        end
+    | _ -> ()
+  end;
+
   begin
     match ndet with
     | None -> ()
@@ -219,6 +240,7 @@ let run check_only ?ndet ?state ?read ?write ezfio_filename =
   let output = (file_header ezfio_filename) :: (
     List.map get [
       Ao_basis ;
+      Ao_extra_basis ;
       Mo_basis ;
     ])
    in
@@ -229,6 +251,7 @@ let run check_only ?ndet ?state ?read ?write ezfio_filename =
   let tasks = [
       Nuclei_by_hand ;
       Ao_basis;
+      Ao_extra_basis;
       Electrons ;
 {tasks}
       Mo_basis;

src/nuclei/nuclei.irp.f

@@ -201,6 +201,9 @@ BEGIN_PROVIDER [ double precision, nuclear_repulsion ]
          x(2) = nucl_coord(k,2) - nucl_coord(l,2)
          x(3) = nucl_coord(k,3) - nucl_coord(l,3)
          r2 = x(1)*x(1) + x(2)*x(2) + x(3)*x(3)
+         if(r2.lt.1.d-6)then
+          r2 = 1.d-6
+         endif
          nuclear_repulsion += Z12/dsqrt(r2)
        enddo
      enddo