fixed array size

fixed complex/real bug

REPLACE

@@ -1,5 +1,4 @@
 # This file contains all the renamings that occured between qp1 and qp2.
-#
 qp_name aa_operator_bielec -r aa_operator_two_e
 qp_name ac_operator_bielec -r ac_operator_two_e
 qp_name ao_bi_elec_integral_alpha -r ao_two_e_integral_alpha
@@ -127,7 +126,6 @@ qp_name H_S2_u_0_bielec_nstates_openmp_work_3 -r H_S2_u_0_two_e_nstates_openmp_w
 qp_name H_S2_u_0_bielec_nstates_openmp_work_4 -r H_S2_u_0_two_e_nstates_openmp_work_4
 qp_name H_S2_u_0_bielec_nstates_openmp_work_$N_int
 qp_name H_S2_u_0_bielec_nstates_openmp_work_$N_int -r "H_S2_u_0_two_e_nstates_openmp_work_$N_int"
-qp_name H_S2_u_0_bielec_nstates_openmp_work_$N_int #-r "H_S2_u_0_two_e_nstates_openmp_work_$N_int"
 qp_name H_S2_u_0_bielec_nstates_openmp_work -r H_S2_u_0_two_e_nstates_openmp_work
 qp_name H_S2_u_0_bielec_nstates_openmp_work_ -r H_S2_u_0_two_e_nstates_openmp_work_
 qp_name i_H_j_bielec -r i_H_j_two_e
@@ -223,6 +221,7 @@ qp_name potential_sr_xc_beta_ao_lda --rename=potential_xc_beta_ao_sr_lda
 qp_name potential_sr_xc_beta_ao_pbe  --rename=potential_xc_beta_ao_sr_pbe
 qp_name potential_sr_xc_beta_ao_pbe --rename=potential_xc_beta_ao_sr_pbe
 qp_name psi_energy_bielec -r psi_energy_two_e
+qp_name read_ao_integrals_e_n -r read_ao_integrals_n_e
 qp_name read_ao_integrals --rename="read_ao_two_e_integrals"
 qp_name read_ao_integrals --rename=read_ao_two_e_integrals
 qp_name read_mo_integrals_erf -r read_mo_two_e_integrals_erf
@@ -240,3 +239,11 @@ qp_name write_ao_integrals --rename=write_ao_two_e_integrals
 qp_name write_mo_integrals_erf -r write_mo_two_e_integrals_erf
 qp_name write_mo_integrals --rename="write_mo_two_e_integrals"
 qp_name write_mo_integrals --rename=write_mo_two_e_integrals
+qp_name ao_ortho_canonical_coef_inv_complex -r ao_ortho_cano_coef_inv_cplx
+qp_name fock_operator_closed_shell_ref_bitmask -r fock_op_cshell_ref_bitmask
+qp_name fock_operator_closed_shell_ref_bitmask_complex -r fock_op_cshell_ref_bitmask_cplx
+qp_name ao_ortho_canonical_coef_inv -r ao_ortho_cano_coef_inv
+qp_name ao_ortho_cano_to_ao_complex -r ao_ortho_cano_to_ao_cplx
+qp_name ao_ortho_lowdin_nucl_elec_integrals_complex -r ao_ortho_lowdin_n_e_ints_cplx
+qp_name ao_ortho_canonical_nucl_elec_integrals_complex -r ao_ortho_cano_n_e_ints_cplx
+qp_name ao_ortho_canonical_nucl_elec_integrals -r ao_ortho_cano_n_e_ints

config/ifort_avx.cfg

@@ -32,7 +32,7 @@ OPENMP  : 1          ; Append OpenMP flags
 #
 [OPT]
 FC       : -traceback
-FCFLAGS  : -xAVX -O2 -ip -ftz -g 
+FCFLAGS  : -mavx -O2 -ip -ftz -g
 
 # Profiling flags
 #################

configure

@@ -1,4 +1,4 @@
-#!/bin/bash 
+#!/bin/bash
 #
 # Quantum Package configuration script
 #
@@ -45,7 +45,7 @@ Usage:
 
 Options:
   -c, --config=<file>      Define a COMPILATION configuration file,
-                           in "${QP_ROOT}/config/". 
+                           in "${QP_ROOT}/config/".
   -h, --help               Print the HELP message
   -i, --install=<package>  INSTALL <package>. Use at your OWN RISK:
                            no support will be provided for the installation of
@@ -73,7 +73,7 @@ function execute () {
     while read -r line; do
       echo "  " $line
       _command+="${line} ;"
-    done 
+    done
     sleep 1
     echo ""
     printf "\e[0;94m"
@@ -87,7 +87,7 @@ OCAML_PACKAGES="ocamlbuild cryptokit zmq sexplib ppx_sexp_conv ppx_deriving geto
 
 while true ; do
     case "$1" in
-        -c|--config) 
+        -c|--config)
             case "$2" in
                 "") help ; break;;
                 *) if [[ -f $2 ]] ; then
@@ -96,15 +96,15 @@ while true ; do
                       error "error: configuration file $2 not found."
                       exit 1
                    fi
-            esac 
+            esac
             shift 2;;
         -i|--install)
             case "$2" in
                 "") help ; break;;
                 *) PACKAGES="${PACKAGE} $2"
-            esac 
+            esac
             shift 2;;
-        -h|-help|--help) 
+        -h|-help|--help)
             help
             exit 0;;
         --) shift ; break ;;
@@ -183,7 +183,7 @@ EZFIO=$(find_dir "${QP_ROOT}"/external/ezfio)
 if [[ ${EZFIO} = $(not_found) ]] ; then
             execute << EOF
               cd "\${QP_ROOT}"/external
-              tar --gunzip --extract --file ${EZFIO_TGZ} 
+              tar --gunzip --extract --file ${EZFIO_TGZ}
               rm -rf ezfio
               mv EZFIO ezfio
 EOF
@@ -237,7 +237,7 @@ EOF
               ./configure --prefix=$QP_ROOT && make -j 8
               make install
 EOF
-    
+
     elif [[ ${PACKAGE} = libcap ]] ; then
 
             download ${LIBCAP_URL} "${QP_ROOT}"/external/libcap.tar.gz
@@ -272,7 +272,7 @@ EOF
               cd irpf90-*
               make
 EOF
-    
+
 
     elif [[ ${PACKAGE} = zeromq ]] ; then
 
@@ -303,7 +303,7 @@ EOF
               cp f77_zmq_free.h "\${QP_ROOT}"/include
 EOF
 
-    
+
     elif [[ ${PACKAGE} = ocaml ]] ; then
 
             download ${OCAML_URL} "${QP_ROOT}"/external/opam_installer.sh
@@ -316,7 +316,7 @@ EOF
                         rm -rf ${HOME}/.opam
                 fi
                 export OPAMROOT=${HOME}/.opam
-                cat << EOF | bash ${QP_ROOT}/external/opam_installer.sh --no-backup 
+                cat << EOF | bash ${QP_ROOT}/external/opam_installer.sh --no-backup
 ${QP_ROOT}/bin
 
 
@@ -336,13 +336,13 @@ EOF
                 # Conventional commands
                 execute << EOF
                   chmod +x "${QP_ROOT}"/external/opam_installer.sh
-                  "${QP_ROOT}"/external/opam_installer.sh --no-backup 
+                  "${QP_ROOT}"/external/opam_installer.sh --no-backup
 EOF
                 execute << EOF
                   rm --force ${QP_ROOT}/bin/opam
                   export OPAMROOT=${OPAMROOT:-${QP_ROOT}/external/opam}
                   echo ${QP_ROOT}/bin \
-                  | sh ${QP_ROOT}/external/opam_installer.sh 
+                  | sh ${QP_ROOT}/external/opam_installer.sh
 EOF
                 rm ${QP_ROOT}/external/opam_installer.sh
 #                source ${OPAMROOT}/opam-init/init.sh > /dev/null 2> /dev/null || true
@@ -355,7 +355,6 @@ EOF
 EOF
             fi
 
-            
     elif [[ ${PACKAGE} = bse ]] ; then
 
             download ${BSE_URL} "${QP_ROOT}"/external/bse.tar.gz
@@ -363,7 +362,6 @@ EOF
               cd "\${QP_ROOT}"/external
               tar --gunzip --extract --file bse.tar.gz
               pip install -e basis_set_exchange-*
-EOF
     elif [[ ${PACKAGE} = zlib ]] ; then
 
             download ${ZLIB_URL} "${QP_ROOT}"/external/zlib.tar.gz
@@ -376,13 +374,13 @@ EOF
               make && make install
 EOF
 
-            
+
     elif [[ ${PACKAGE} = docopt ]] ; then
 
             download ${DOCOPT_URL} "${QP_ROOT}"/external/docopt.tar.gz
             execute << EOF
               cd "\${QP_ROOT}"/external
-              tar --gunzip --extract --file docopt.tar.gz 
+              tar --gunzip --extract --file docopt.tar.gz
               mv docopt-*/docopt.py "\${QP_ROOT}/external/Python"
               rm --recursive --force -- docopt-*/ docopt.tar.gz
 EOF
@@ -393,7 +391,7 @@ EOF
             download ${RESULTS_URL} "${QP_ROOT}"/external/resultsFile.tar.gz
             execute << EOF
               cd "\${QP_ROOT}"/external
-              tar --gunzip --extract --file resultsFile.tar.gz 
+              tar --gunzip --extract --file resultsFile.tar.gz
               mv resultsFile-*/resultsFile "\${QP_ROOT}/external/Python/"
               rm --recursive --force resultsFile-* resultsFile.tar.gz
 EOF
@@ -403,7 +401,7 @@ EOF
             download ${BATS_URL} "${QP_ROOT}"/external/bats.tar.gz
             execute << EOF
               cd "\${QP_ROOT}"/external
-              tar -zxf bats.tar.gz 
+              tar -zxf bats.tar.gz
               ( cd bats-core-1.1.0/ ; ./install.sh \${QP_ROOT})
               rm --recursive --force -- bats-core-1.1.0 \  "\${QP_ROOT}"/external/bats.tar.gz
 EOF
@@ -515,15 +513,15 @@ fi
 
 if [[ -f ${QP_ROOT}/build.ninja ]] ; then
   [[ -z ${TRAVIS} ]] && echo "You can now run ./bin/qpsh to enter in the QP shell mode :)"
-else 
+else
       echo ""
       echo "${QP_ROOT}/build.ninja does not exist,"
       echo "you need to specify the COMPILATION configuration file."
-      echo "See  ./configure --help  for more details." 
+      echo "See  ./configure --help  for more details."
       echo ""
 fi
 
 exit 0
-    
+
 
 

ocaml/Input_determinants_by_hand.ml

@@ -37,7 +37,9 @@ end = struct
     } [@@deriving sexp]
   ;;
 
-  let get_default = Qpackage.get_ezfio_default "determinants";;
+  let get_default = Qpackage.get_ezfio_default "determinants"
+
+  let is_complex = lazy (Ezfio.get_nuclei_is_complex () )
 
   let read_n_int () =
     if not (Ezfio.has_determinants_n_int()) then
@@ -48,12 +50,12 @@ end = struct
     ;
     Ezfio.get_determinants_n_int ()
     |> N_int_number.of_int
-  ;;
+
 
   let write_n_int n =
     N_int_number.to_int n
     |> Ezfio.set_determinants_n_int
-  ;;
+
 
 
   let read_bit_kind () =
@@ -64,12 +66,12 @@ end = struct
     ;
     Ezfio.get_determinants_bit_kind ()
     |> Bit_kind.of_int
-  ;;
+
 
   let write_bit_kind b =
     Bit_kind.to_int b
     |> Ezfio.set_determinants_bit_kind
-  ;;
+
 
   let read_n_det () =
     if not (Ezfio.has_determinants_n_det ()) then
@@ -77,7 +79,7 @@ end = struct
     ;
     Ezfio.get_determinants_n_det ()
     |> Det_number.of_int
-  ;;
+
 
   let read_n_det_qp_edit () =
     if not (Ezfio.has_determinants_n_det_qp_edit ()) then
@@ -87,18 +89,18 @@ end = struct
       end;
     Ezfio.get_determinants_n_det_qp_edit ()
     |> Det_number.of_int
-  ;;
+
 
   let write_n_det n =
     Det_number.to_int n
     |> Ezfio.set_determinants_n_det
-  ;;
+
 
   let write_n_det_qp_edit n =
     let n_det = read_n_det () |> Det_number.to_int in
     min n_det (Det_number.to_int n)
     |> Ezfio.set_determinants_n_det_qp_edit
-  ;;
+
 
   let read_n_states () =
     if not (Ezfio.has_determinants_n_states ()) then
@@ -106,7 +108,7 @@ end = struct
     ;
     Ezfio.get_determinants_n_states ()
     |> States_number.of_int
-  ;;
+
 
   let write_n_states n =
     let n_states =
@@ -130,7 +132,7 @@ end = struct
         Ezfio.ezfio_array_of_list ~rank:1 ~dim:[| n_states |] ~data
         |> Ezfio.set_determinants_state_average_weight
       end
-  ;;
+
 
   let write_state_average_weight data =
       let n_states =
@@ -143,7 +145,7 @@ end = struct
       in
       Ezfio.ezfio_array_of_list ~rank:1 ~dim:[| n_states |] ~data
       |> Ezfio.set_determinants_state_average_weight
-  ;;
+
 
   let read_state_average_weight () =
     let n_states =
@@ -171,7 +173,7 @@ end = struct
         |> Array.map Positive_float.of_float
       in
       (write_state_average_weight data; data)
-  ;;
+
 
   let read_expected_s2 () =
     if not (Ezfio.has_determinants_expected_s2 ()) then
@@ -186,12 +188,12 @@ end = struct
     ;
     Ezfio.get_determinants_expected_s2 ()
     |> Positive_float.of_float
-  ;;
+
 
   let write_expected_s2 s2 =
     Positive_float.to_float s2
     |> Ezfio.set_determinants_expected_s2
-  ;;
+
 
   let read_psi_coef ~read_only () =
     if not (Ezfio.has_determinants_psi_coef ()) then
@@ -200,19 +202,36 @@ end = struct
           read_n_states ()
           |> States_number.to_int
         in
-        Ezfio.ezfio_array_of_list ~rank:2 ~dim:[| 1 ; n_states |]
-          ~data:(List.init n_states (fun i -> if (i=0) then 1. else 0. ))
+        (
+        if Lazy.force is_complex then
+          Ezfio.ezfio_array_of_list ~rank:2 ~dim:[| 1 ; n_states |]
+            ~data:(List.init (2*n_states) (fun i -> if (i=0) then 1. else 0. ))
           |> Ezfio.set_determinants_psi_coef
+        else
+          Ezfio.ezfio_array_of_list ~rank:3 ~dim:[| 2 ; 1 ; n_states |]
+            ~data:(List.init n_states (fun i -> if (i=0) then 1. else 0. ))
+          |> Ezfio.set_determinants_psi_coef_complex
+        )
       end;
     begin
       if read_only then
-        Ezfio.get_determinants_psi_coef_qp_edit ()
+        begin
+          if Lazy.force is_complex then
+            Ezfio.get_determinants_psi_coef_complex_qp_edit ()
+          else
+            Ezfio.get_determinants_psi_coef_qp_edit ()
+        end
       else
-        Ezfio.get_determinants_psi_coef ()
+        begin
+          if Lazy.force is_complex then
+            Ezfio.get_determinants_psi_coef_complex ()
+          else
+            Ezfio.get_determinants_psi_coef ()
+        end
     end
     |> Ezfio.flattened_ezfio
     |> Array.map Det_coef.of_float
-  ;;
+
 
   let write_psi_coef ~n_det ~n_states c =
     let n_det = Det_number.to_int n_det
@@ -222,12 +241,23 @@ end = struct
     and n_states =
       States_number.to_int n_states
     in
-    let r = 
-      Ezfio.ezfio_array_of_list ~rank:2 ~dim:[| n_det ; n_states |] ~data:c
-    in
-    Ezfio.set_determinants_psi_coef r;
-    Ezfio.set_determinants_psi_coef_qp_edit r
-  ;;
+    if Lazy.force is_complex then
+      begin
+        let r = 
+          Ezfio.ezfio_array_of_list ~rank:3 ~dim:[| 2 ; n_det ; n_states |] ~data:c
+        in
+        Ezfio.set_determinants_psi_coef_complex r;
+        Ezfio.set_determinants_psi_coef_complex_qp_edit r
+      end
+    else
+      begin
+        let r = 
+          Ezfio.ezfio_array_of_list ~rank:2 ~dim:[| n_det ; n_states |] ~data:c
+        in
+        Ezfio.set_determinants_psi_coef r;
+        Ezfio.set_determinants_psi_coef_qp_edit r
+      end
+
 
 
   let read_psi_det ~read_only () =
@@ -276,7 +306,7 @@ end = struct
     |> Array.map (Determinant.of_int64_array
       ~n_int:(N_int_number.of_int n_int)
       ~alpha:n_alpha ~beta:n_beta )
-  ;;
+
 
   let write_psi_det ~n_int ~n_det d =
     let data = Array.to_list d
@@ -288,7 +318,7 @@ end = struct
     in
     Ezfio.set_determinants_psi_det r;
     Ezfio.set_determinants_psi_det_qp_edit r
-  ;;
+
 
 
   let read ?(full=true) () =
@@ -316,7 +346,7 @@ end = struct
     else
       (* No molecular orbitals, so no determinants *)
       None
-  ;;
+
 
   let write ?(force=false)
     { n_int                ;
@@ -341,7 +371,7 @@ end = struct
           write_psi_det ~n_int:n_int ~n_det:n_det psi_det
         end;
      write_state_average_weight state_average_weight
-  ;;
+
 
 
   let to_rst b =
@@ -557,10 +587,8 @@ psi_det                = %s
     in
 
 
-
-
     Generic_input_of_rst.evaluate_sexp t_of_sexp s
-  ;;
+
 
   let update_ndet n_det_new =
     Printf.printf "Reducing n_det to %d\n" (Det_number.to_int n_det_new);
@@ -596,7 +624,7 @@ psi_det                = %s
       { det with n_det = (Det_number.of_int n_det_new) }
     in
     write ~force:true new_det
-  ;;
+
 
   let extract_state istate =
     Printf.printf "Extracting state %d\n" (States_number.to_int istate);
@@ -628,7 +656,7 @@ psi_det                = %s
       { det with n_states = (States_number.of_int 1) }
     in
     write ~force:true new_det
-  ;;
+
 
   let extract_states range =
     Printf.printf "Extracting states %s\n" (Range.to_string range);
@@ -673,7 +701,7 @@ psi_det                = %s
       { det with n_states = (States_number.of_int @@ List.length sorted_list) }
     in
     write ~force:true new_det
-  ;;
+
 
 end
 

ocaml/Input_mo_basis.ml

@@ -2,7 +2,6 @@ open Qptypes
 open Qputils
 open Sexplib.Std
 
-
 module Mo_basis : sig
   type t =
       { mo_num          : MO_number.t ;
@@ -26,8 +25,11 @@ end = struct
         mo_coef         : (MO_coef.t array) array;
         ao_md5          : MD5.t;
       } [@@deriving sexp]
+
   let get_default = Qpackage.get_ezfio_default "mo_basis"
 
+  let is_complex = lazy (Ezfio.get_nuclei_is_complex () )
+
   let read_mo_label () =
     if not (Ezfio.has_mo_basis_mo_label ()) then
       Ezfio.set_mo_basis_mo_label "None"
@@ -37,11 +39,11 @@ end = struct
 
 
   let reorder b ordering =
-    { b with mo_coef =
-      Array.map (fun mo ->
-        Array.init (Array.length mo)
-          (fun i -> mo.(ordering.(i)))
-      ) b.mo_coef 
+    { b with
+      mo_coef = Array.map (fun mo ->
+          Array.init (Array.length mo)
+            (fun i -> mo.(ordering.(i)))
+        ) b.mo_coef
     }
 
   let read_ao_md5 () =
@@ -60,7 +62,10 @@ end = struct
       |> MD5.of_string
     in
     if (ao_md5 <> result) then
-      failwith "The current MOs don't correspond to the current AOs.";
+      begin
+        Printf.eprintf ":%s:\n:%s:\n%!" (MD5.to_string ao_md5) (MD5.to_string result);
+        failwith "The current MOs don't correspond to the current AOs."
+      end;
     result
 
 
@@ -68,7 +73,7 @@ end = struct
     let elec_alpha_num =
       Ezfio.get_electrons_elec_alpha_num ()
     in
-    let result = 
+    let result =
       Ezfio.get_mo_basis_mo_num ()
     in
     if result < elec_alpha_num then
@@ -111,15 +116,21 @@ end = struct
 
 
   let read_mo_coef () =
-    let a = Ezfio.get_mo_basis_mo_coef ()
-            |> Ezfio.flattened_ezfio
-            |> Array.map MO_coef.of_float
+    let a =
+      (
+        if Lazy.force is_complex then
+           Ezfio.get_mo_basis_mo_coef_complex  ()
+        else
+           Ezfio.get_mo_basis_mo_coef ()
+      )
+      |> Ezfio.flattened_ezfio
+      |> Array.map MO_coef.of_float
     in
     let mo_num = read_mo_num () |> MO_number.to_int in
     let ao_num = (Array.length a)/mo_num in
-    Array.init mo_num (fun j ->
-        Array.sub a (j*ao_num) (ao_num) 
-      )
+      Array.init mo_num (fun j ->
+          Array.sub a (j*ao_num) (ao_num)
+        )
 
 
   let read () =
@@ -236,7 +247,7 @@ mo_coef         = %s
       (b.mo_occ |> Array.to_list |> List.map
          (MO_occ.to_string) |> String.concat ", " )
       (b.mo_coef |> Array.map
-         (fun x-> Array.map MO_coef.to_string x |> 
+         (fun x-> Array.map MO_coef.to_string x |>
            Array.to_list |> String.concat "," ) |>
        Array.to_list |> String.concat "\n" )
 
@@ -244,12 +255,12 @@ mo_coef         = %s
   let write_mo_num n =
     MO_number.to_int n
     |> Ezfio.set_mo_basis_mo_num
-  ;;
+
 
   let write_mo_label a =
     MO_label.to_string a
     |> Ezfio.set_mo_basis_mo_label
-  ;;
+
 
   let write_mo_class a =
     let mo_num = Array.length a in
@@ -257,7 +268,7 @@ mo_coef         = %s
     |> Array.to_list
     in Ezfio.ezfio_array_of_list ~rank:1 ~dim:[| mo_num |] ~data
     |> Ezfio.set_mo_basis_mo_class
-  ;;
+
 
   let write_mo_occ a =
     let mo_num = Array.length a in
@@ -265,26 +276,34 @@ mo_coef         = %s
     |> Array.to_list
     in Ezfio.ezfio_array_of_list ~rank:1 ~dim:[| mo_num |] ~data
     |> Ezfio.set_mo_basis_mo_occ
-  ;;
+
 
   let write_md5 a =
     MD5.to_string a
     |> Ezfio.set_mo_basis_ao_md5
-  ;;
+
 
   let write_mo_coef a =
     let mo_num = Array.length a in
-    let ao_num = Array.length a.(0) in
+    let ao_num =
+      let x = Array.length a.(0) in
+      if Lazy.force is_complex then x/2 else x
+    in
     let data =
       Array.map (fun mo -> Array.map MO_coef.to_float mo
       |> Array.to_list) a
     |> Array.to_list
     |> List.concat
-    in Ezfio.ezfio_array_of_list ~rank:2 ~dim:[| ao_num ; mo_num |] ~data
-    |> Ezfio.set_mo_basis_mo_coef
-  ;;
+    in
+    if Lazy.force is_complex then
+      (Ezfio.ezfio_array_of_list ~rank:3 ~dim:[| 2 ; ao_num ; mo_num |] ~data
+        |> Ezfio.set_mo_basis_mo_coef_complex )
+    else
+       (Ezfio.ezfio_array_of_list ~rank:2 ~dim:[| ao_num ; mo_num |] ~data
+        |> Ezfio.set_mo_basis_mo_coef )
 
-  let write 
+
+  let write
       { mo_num          : MO_number.t ;
         mo_label        : MO_label.t;
         mo_class        : MO_class.t array;
@@ -298,7 +317,7 @@ mo_coef         = %s
       write_mo_occ mo_occ;
       write_mo_coef mo_coef;
       write_md5 ao_md5
-  ;;
+
 
 end
 

ocaml/TaskServer.ml

@@ -885,7 +885,9 @@ let run ~port =
 
     Zmq.Socket.send pair_socket @@ string_of_pub_state Stopped;
     Thread.join pub_thread;
-    Zmq.Socket.close rep_socket
+    Zmq.Socket.close pair_socket;
+    Zmq.Socket.close rep_socket;
+    Zmq.Context.terminate zmq_context
 
 
 

ocaml/qptypes_generator.ml

@@ -166,6 +166,7 @@ let input_ezfio = "
 
 
 let untouched = "
+
 module MO_guess : sig
   type t [@@deriving sexp]
   val to_string : t -> string

src/ao_basis/EZFIO.cfg

@@ -55,3 +55,9 @@ doc: If |true|, use |AOs| in Cartesian coordinates (6d,10f,...)
 interface: ezfio, provider
 default: false
 
+[ao_num_per_kpt]
+type: integer
+doc: Number of |AOs| per kpt
+default: =(ao_basis.ao_num/nuclei.kpt_num)
+interface: ezfio
+

src/ao_basis/aos_cplx.irp.f

@@ -0,0 +1,7 @@
+BEGIN_PROVIDER [ integer, ao_num_per_kpt ]
+ implicit none
+ BEGIN_DOC
+ ! number of aos per kpt.
+ END_DOC
+ ao_num_per_kpt = ao_num/kpt_num
+END_PROVIDER

src/ao_one_e_ints/EZFIO.cfg

@@ -1,10 +1,22 @@
-[ao_integrals_e_n]
+[ao_integrals_n_e]
 type: double precision
 doc: Nucleus-electron integrals in |AO| basis set
 size: (ao_basis.ao_num,ao_basis.ao_num)
 interface: ezfio
 
-[io_ao_integrals_e_n]
+[ao_integrals_n_e_complex]
+type: double precision
+doc: Complex nucleus-electron integrals in |AO| basis set
+size: (2,ao_basis.ao_num,ao_basis.ao_num)
+interface: ezfio
+
+[ao_integrals_n_e_kpts]
+type: double precision
+doc: Complex nucleus-electron integrals in |AO| basis set
+size: (2,ao_basis.ao_num_per_kpt,ao_basis.ao_num_per_kpt,nuclei.kpt_num)
+interface: ezfio
+
+[io_ao_integrals_n_e]
 type: Disk_access
 doc: Read/Write |AO| nucleus-electron attraction integrals from/to disk [ Write | Read | None ]
 interface: ezfio,provider,ocaml
@@ -17,6 +29,18 @@ doc: Kinetic energy integrals in |AO| basis set
 size: (ao_basis.ao_num,ao_basis.ao_num)
 interface: ezfio
 
+[ao_integrals_kinetic_complex]
+type: double precision
+doc: Complex kinetic energy integrals in |AO| basis set
+size: (2,ao_basis.ao_num,ao_basis.ao_num)
+interface: ezfio
+
+[ao_integrals_kinetic_kpts]
+type: double precision
+doc: Complex kinetic energy integrals in |AO| basis set
+size: (2,ao_basis.ao_num_per_kpt,ao_basis.ao_num_per_kpt,nuclei.kpt_num)
+interface: ezfio
+
 [io_ao_integrals_kinetic]
 type: Disk_access
 doc: Read/Write |AO| kinetic integrals from/to disk [ Write | Read | None ]
@@ -30,6 +54,18 @@ doc: Pseudopotential integrals in |AO| basis set
 size: (ao_basis.ao_num,ao_basis.ao_num)
 interface: ezfio
 
+[ao_integrals_pseudo_complex]
+type: double precision
+doc: Complex pseudopotential integrals in |AO| basis set
+size: (2,ao_basis.ao_num,ao_basis.ao_num)
+interface: ezfio
+
+[ao_integrals_pseudo_kpts]
+type: double precision
+doc: Complex pseudopotential integrals in |AO| basis set
+size: (2,ao_basis.ao_num_per_kpt,ao_basis.ao_num_per_kpt,nuclei.kpt_num)
+interface: ezfio
+
 [io_ao_integrals_pseudo]
 type: Disk_access
 doc: Read/Write |AO| pseudopotential integrals from/to disk [ Write | Read | None ]
@@ -43,6 +79,18 @@ doc: Overlap integrals in |AO| basis set
 size: (ao_basis.ao_num,ao_basis.ao_num)
 interface: ezfio
 
+[ao_integrals_overlap_complex]
+type: double precision
+doc: Complex overlap integrals in |AO| basis set
+size: (2,ao_basis.ao_num,ao_basis.ao_num)
+interface: ezfio
+
+[ao_integrals_overlap_kpts]
+type: double precision
+doc: Complex overlap integrals in |AO| basis set
+size: (2,ao_basis.ao_num_per_kpt,ao_basis.ao_num_per_kpt,nuclei.kpt_num)
+interface: ezfio
+
 [io_ao_integrals_overlap]
 type: Disk_access
 doc: Read/Write |AO| overlap integrals from/to disk [ Write | Read | None ]
@@ -56,6 +104,18 @@ doc: Combined integrals in |AO| basis set
 size: (ao_basis.ao_num,ao_basis.ao_num) 
 interface: ezfio
 
+[ao_one_e_integrals_complex]
+type: double precision
+doc: Complex combined integrals in |AO| basis set
+size: (2,ao_basis.ao_num,ao_basis.ao_num) 
+interface: ezfio
+
+[ao_one_e_integrals_kpts]
+type: double precision
+doc: Complex combined integrals in |AO| basis set
+size: (2,ao_basis.ao_num_per_kpt,ao_basis.ao_num_per_kpt,nuclei.kpt_num) 
+interface: ezfio
+
 [io_ao_one_e_integrals]
 type: Disk_access
 doc: Read/Write |AO| one-electron integrals from/to disk [ Write | Read | None ]

src/ao_one_e_ints/ao_one_e_ints.irp.f

@@ -5,7 +5,10 @@
   BEGIN_DOC
  ! One-electron Hamiltonian in the |AO| basis.
   END_DOC
-
+  if (is_complex) then
+    print*,"you shouldn't be here for complex",irp_here
+    stop -1
+  endif
   IF (read_ao_one_e_integrals) THEN
      call ezfio_get_ao_one_e_ints_ao_one_e_integrals(ao_one_e_integrals)
   ELSE
@@ -27,3 +30,85 @@
 
 END_PROVIDER
 
+!BEGIN_PROVIDER [ double precision, ao_one_e_integrals_imag,(ao_num,ao_num)]
+!  implicit none
+!  integer :: i,j,n,l
+!  BEGIN_DOC
+! ! One-electron Hamiltonian in the |AO| basis.
+!  END_DOC
+!
+!  IF (read_ao_one_e_integrals) THEN
+!     call ezfio_get_ao_one_e_ints_ao_one_e_integrals_imag(ao_one_e_integrals_imag)
+!  ELSE
+!        ao_one_e_integrals_imag = ao_integrals_n_e_imag + ao_kinetic_integrals_imag
+!
+!        IF (DO_PSEUDO) THEN
+!              ao_one_e_integrals_imag += ao_pseudo_integrals_imag
+!        ENDIF
+!  ENDIF
+!
+!  IF (write_ao_one_e_integrals) THEN
+!       call ezfio_set_ao_one_e_ints_ao_one_e_integrals_imag(ao_one_e_integrals_imag)
+!       print *,  'AO one-e integrals written to disk'
+!  ENDIF
+!
+!END_PROVIDER
+
+ BEGIN_PROVIDER [ complex*16, ao_one_e_integrals_complex,(ao_num,ao_num)]
+&BEGIN_PROVIDER [ double precision, ao_one_e_integrals_diag_complex,(ao_num)]
+  implicit none
+  integer :: i,j,n,l
+  BEGIN_DOC
+ ! One-electron Hamiltonian in the |AO| basis.
+  END_DOC
+  
+  IF (read_ao_one_e_integrals) THEN
+     call ezfio_get_ao_one_e_ints_ao_one_e_integrals_complex(ao_one_e_integrals_complex)
+  ELSE
+        ao_one_e_integrals_complex = ao_integrals_n_e_complex + ao_kinetic_integrals_complex
+
+        IF (DO_PSEUDO) THEN
+              ao_one_e_integrals_complex += ao_pseudo_integrals_complex
+        ENDIF
+  ENDIF
+
+  DO j = 1, ao_num
+    ao_one_e_integrals_diag_complex(j) = dble(ao_one_e_integrals_complex(j,j))
+  ENDDO
+
+  IF (write_ao_one_e_integrals) THEN
+       call ezfio_set_ao_one_e_ints_ao_one_e_integrals_complex(ao_one_e_integrals_complex)
+       print *,  'AO one-e integrals written to disk'
+  ENDIF
+END_PROVIDER
+
+ BEGIN_PROVIDER [ complex*16, ao_one_e_integrals_kpts,(ao_num_per_kpt,ao_num_per_kpt,kpt_num)]
+&BEGIN_PROVIDER [ double precision, ao_one_e_integrals_diag_kpts,(ao_num_per_kpt,kpt_num)]
+  implicit none
+  integer :: j,k
+  BEGIN_DOC
+ ! One-electron Hamiltonian in the |AO| basis.
+  END_DOC
+  
+  if (read_ao_one_e_integrals) then
+     call ezfio_get_ao_one_e_ints_ao_one_e_integrals_kpts(ao_one_e_integrals_kpts)
+  else
+        ao_one_e_integrals_kpts = ao_integrals_n_e_kpts + ao_kinetic_integrals_kpts
+
+        if (do_pseudo) then
+              ao_one_e_integrals_kpts += ao_pseudo_integrals_kpts
+        endif
+  endif
+
+  do k = 1, kpt_num
+    do j = 1, ao_num_per_kpt
+      ao_one_e_integrals_diag_kpts(j,k) = dble(ao_one_e_integrals_kpts(j,j,k))
+    enddo
+  enddo
+
+  if (write_ao_one_e_integrals) then
+       call ezfio_set_ao_one_e_ints_ao_one_e_integrals_kpts(ao_one_e_integrals_kpts)
+       print *,  'AO one-e integrals written to disk'
+  endif
+END_PROVIDER
+

src/ao_one_e_ints/ao_ortho_cano.irp.f

@@ -84,13 +84,13 @@ END_PROVIDER
 
 
 
-BEGIN_PROVIDER [ double precision, ao_ortho_canonical_coef_inv, (ao_num,ao_num)]
+BEGIN_PROVIDER [ double precision, ao_ortho_cano_coef_inv, (ao_num,ao_num)]
  implicit none
  BEGIN_DOC
 ! ao_ortho_canonical_coef^(-1)
  END_DOC
  call get_inverse(ao_ortho_canonical_coef,size(ao_ortho_canonical_coef,1),&
-     ao_num, ao_ortho_canonical_coef_inv, size(ao_ortho_canonical_coef_inv,1))
+     ao_num, ao_ortho_cano_coef_inv, size(ao_ortho_cano_coef_inv,1))
 END_PROVIDER
 
  BEGIN_PROVIDER [ double precision, ao_ortho_canonical_coef, (ao_num,ao_num)]

src/ao_one_e_ints/ao_ortho_cano_cplx.irp.f

@@ -0,0 +1,121 @@
+!todo: add kpts
+BEGIN_PROVIDER [ complex*16, ao_cart_to_sphe_coef_complex, (ao_num,ao_cart_to_sphe_num) ]
+ implicit none
+ BEGIN_DOC
+ ! complex version of ao_cart_to_sphe_coef
+ END_DOC
+ call zlacp2('A',ao_num,ao_cart_to_sphe_num, &
+        ao_cart_to_sphe_coef,size(ao_cart_to_sphe_coef,1), &
+        ao_cart_to_sphe_coef_complex,size(ao_cart_to_sphe_coef_complex,1))
+END_PROVIDER
+
+BEGIN_PROVIDER [ complex*16, ao_cart_to_sphe_overlap_complex, (ao_cart_to_sphe_num,ao_cart_to_sphe_num) ]
+ implicit none
+ BEGIN_DOC
+ ! AO overlap matrix in the spherical basis set
+ END_DOC
+ complex*16, allocatable :: S(:,:)
+ allocate (S(ao_cart_to_sphe_num,ao_num))
+
+ call zgemm('T','N',ao_cart_to_sphe_num,ao_num,ao_num, (1.d0,0.d0), &
+   ao_cart_to_sphe_coef_complex,size(ao_cart_to_sphe_coef_complex,1), &
+   ao_overlap_complex,size(ao_overlap_complex,1), (0.d0,0.d0), &
+   S, size(S,1))
+
+ call zgemm('N','N',ao_cart_to_sphe_num,ao_cart_to_sphe_num,ao_num, (1.d0,0.d0), &
+   S, size(S,1), &
+   ao_cart_to_sphe_coef_complex,size(ao_cart_to_sphe_coef_complex,1), (0.d0,0.d0), &
+   ao_cart_to_sphe_overlap_complex,size(ao_cart_to_sphe_overlap_complex,1))
+
+ deallocate(S)
+
+END_PROVIDER
+
+
+
+
+BEGIN_PROVIDER [ complex*16, ao_ortho_cano_coef_inv_cplx, (ao_num,ao_num)]
+ implicit none
+ BEGIN_DOC
+! ao_ortho_canonical_coef_complex^(-1)
+ END_DOC
+ call get_inverse_complex(ao_ortho_canonical_coef_complex,size(ao_ortho_canonical_coef_complex,1),&
+     ao_num, ao_ortho_cano_coef_inv_cplx, size(ao_ortho_cano_coef_inv_cplx,1))
+END_PROVIDER
+
+ BEGIN_PROVIDER [ complex*16, ao_ortho_canonical_coef_complex, (ao_num,ao_num)]
+&BEGIN_PROVIDER [ integer, ao_ortho_canonical_num_complex ]
+  implicit none
+  BEGIN_DOC
+! TODO: ao_ortho_canonical_num_complex should be the same as the real version
+!       maybe if the providers weren't linked we could avoid making a complex one?
+! matrix of the coefficients of the mos generated by the
+! orthonormalization by the S^{-1/2} canonical transformation of the aos
+! ao_ortho_canonical_coef(i,j) = coefficient of the ith ao on the jth ao_ortho_canonical orbital
+  END_DOC
+  integer :: i
+  ao_ortho_canonical_coef_complex = (0.d0,0.d0)
+  do i=1,ao_num
+    ao_ortho_canonical_coef_complex(i,i) = (1.d0,0.d0)
+  enddo
+
+!call ortho_lowdin(ao_overlap,size(ao_overlap,1),ao_num,ao_ortho_canonical_coef,size(ao_ortho_canonical_coef,1),ao_num)
+!ao_ortho_canonical_num=ao_num
+!return
+
+  if (ao_cartesian) then
+
+    ao_ortho_canonical_num_complex = ao_num
+    call ortho_canonical_complex(ao_overlap,size(ao_overlap,1), &
+      ao_num,ao_ortho_canonical_coef_complex,size(ao_ortho_canonical_coef_complex,1), &
+      ao_ortho_canonical_num_complex)
+
+
+  else
+
+    complex*16, allocatable :: S(:,:)
+
+    allocate(S(ao_cart_to_sphe_num,ao_cart_to_sphe_num))
+    S = (0.d0,0.d0)
+    do i=1,ao_cart_to_sphe_num
+      S(i,i) = (1.d0,0.d0)
+    enddo
+
+    ao_ortho_canonical_num_complex = ao_cart_to_sphe_num
+    call ortho_canonical_complex(ao_cart_to_sphe_overlap_complex, size(ao_cart_to_sphe_overlap_complex,1), &
+      ao_cart_to_sphe_num, S, size(S,1), ao_ortho_canonical_num_complex)
+
+    call zgemm('N','N', ao_num, ao_ortho_canonical_num_complex, ao_cart_to_sphe_num, (1.d0,0.d0), &
+      ao_cart_to_sphe_coef_complex, size(ao_cart_to_sphe_coef_complex,1), &
+      S, size(S,1), &
+      (0.d0,0.d0), ao_ortho_canonical_coef_complex, size(ao_ortho_canonical_coef_complex,1))
+
+    deallocate(S)
+  endif
+END_PROVIDER
+
+BEGIN_PROVIDER [complex*16, ao_ortho_canonical_overlap_complex, (ao_ortho_canonical_num_complex,ao_ortho_canonical_num_complex)]
+  implicit none
+  BEGIN_DOC
+! overlap matrix of the ao_ortho_canonical.
+! Expected to be the Identity
+  END_DOC
+  integer                        :: i,j,k,l
+  complex*16               :: c
+  do j=1, ao_ortho_canonical_num_complex
+    do i=1, ao_ortho_canonical_num_complex
+      ao_ortho_canonical_overlap_complex(i,j) = (0.d0,0.d0)
+    enddo
+  enddo
+  do j=1, ao_ortho_canonical_num_complex
+    do k=1, ao_num
+      c = (0.d0,0.d0)
+      do l=1, ao_num
+        c +=  conjg(ao_ortho_canonical_coef_complex(l,j)) * ao_overlap_complex(l,k)
+      enddo
+      do i=1, ao_ortho_canonical_num_complex
+        ao_ortho_canonical_overlap_complex(i,j) += ao_ortho_canonical_coef_complex(k,i) * c
+      enddo
+    enddo
+  enddo
+END_PROVIDER

src/ao_one_e_ints/ao_ortho_cano_kpts.irp.f

@@ -0,0 +1,196 @@
+!todo: add kpts
+
+ BEGIN_PROVIDER [ complex*16, ao_cart_to_sphe_coef_kpts, (ao_num_per_kpt,ao_num_per_kpt)]
+&BEGIN_PROVIDER [ integer, ao_cart_to_sphe_num_per_kpt ]
+  implicit none
+  BEGIN_DOC
+! Coefficients to go from cartesian to spherical coordinates in the current
+! basis set
+  END_DOC
+  integer :: i
+  integer, external              :: ao_power_index
+  integer                        :: ibegin,j,k
+  integer                        :: prev
+  prev = 0
+  ao_cart_to_sphe_coef_kpts(:,:) = (0.d0,0.d0)
+  ! Assume order provided by ao_power_index
+  i = 1
+  ao_cart_to_sphe_num_per_kpt = 0
+  do while (i <= ao_num_per_kpt)
+    select case ( ao_l(i) )
+      case (0)
+        ao_cart_to_sphe_num_per_kpt += 1
+        ao_cart_to_sphe_coef_kpts(i,ao_cart_to_sphe_num_per_kpt) = (1.d0,0.d0)
+        i += 1
+      BEGIN_TEMPLATE
+      case ($SHELL)
+        if (ao_power(i,1) == $SHELL) then
+          do k=1,size(cart_to_sphe_$SHELL,2)
+            do j=1,size(cart_to_sphe_$SHELL,1)
+              ao_cart_to_sphe_coef_kpts(i+j-1,ao_cart_to_sphe_num_per_kpt+k) = dcmplx(cart_to_sphe_$SHELL(j,k),0.d0)
+            enddo
+          enddo
+          i += size(cart_to_sphe_$SHELL,1)
+          ao_cart_to_sphe_num_per_kpt += size(cart_to_sphe_$SHELL,2)
+        endif
+      SUBST [ SHELL ]
+        1;;
+        2;;
+        3;;
+        4;;
+        5;;
+        6;;
+        7;;
+        8;;
+        9;;
+      END_TEMPLATE
+      case default
+        stop 'Error in ao_cart_to_sphe_kpts : angular momentum too high'
+    end select
+  enddo
+
+END_PROVIDER
+!BEGIN_PROVIDER [ integer, ao_cart_to_sphe_num_per_kpt ]
+!  implicit none
+!  ao_cart_to_sphe_num_per_kpt = ao_cart_to_sphe_num / kpt_num
+!END_PROVIDER
+!
+!BEGIN_PROVIDER [ complex*16, ao_cart_to_sphe_coef_kpts, (ao_num_per_kpt,ao_cart_to_sphe_num_per_kpt) ]
+! implicit none
+! BEGIN_DOC
+! ! complex version of ao_cart_to_sphe_coef for one k-point
+! END_DOC
+! call zlacp2('A',ao_num_per_kpt,ao_cart_to_sphe_num_per_kpt, &
+!        ao_cart_to_sphe_coef,size(ao_cart_to_sphe_coef,1), &
+!        ao_cart_to_sphe_coef_kpts,size(ao_cart_to_sphe_coef_kpts,1))
+!END_PROVIDER
+
+BEGIN_PROVIDER [ complex*16, ao_cart_to_sphe_overlap_kpts, (ao_cart_to_sphe_num_per_kpt,ao_cart_to_sphe_num_per_kpt,kpt_num) ]
+  implicit none
+  BEGIN_DOC
+  ! AO overlap matrix in the spherical basis set
+  END_DOC
+  integer :: k
+  complex*16, allocatable :: S(:,:)
+  allocate (S(ao_cart_to_sphe_num_per_kpt,ao_num_per_kpt))
+
+  !todo: call with (:,:,k) vs (1,1,k)? is there a difference? does one create a temporary array?
+  do k=1, kpt_num
+   
+    call zgemm('T','N',ao_cart_to_sphe_num_per_kpt,ao_num_per_kpt,ao_num_per_kpt, (1.d0,0.d0), &
+      ao_cart_to_sphe_coef_kpts,size(ao_cart_to_sphe_coef_kpts,1), &
+      ao_overlap_kpts(:,:,k),size(ao_overlap_kpts,1), (0.d0,0.d0), &
+      S, size(S,1))
+   
+    call zgemm('N','N',ao_cart_to_sphe_num_per_kpt,ao_cart_to_sphe_num_per_kpt,ao_num_per_kpt, (1.d0,0.d0), &
+      S, size(S,1), &
+      ao_cart_to_sphe_coef_kpts,size(ao_cart_to_sphe_coef_kpts,1), (0.d0,0.d0), &
+      ao_cart_to_sphe_overlap_kpts(:,:,k),size(ao_cart_to_sphe_overlap_kpts,1))
+  enddo 
+  deallocate(S)
+
+END_PROVIDER
+
+
+
+
+BEGIN_PROVIDER [ complex*16, ao_ortho_cano_coef_inv_kpts, (ao_num_per_kpt,ao_num_per_kpt, kpt_num)]
+ implicit none
+ BEGIN_DOC
+! ao_ortho_canonical_coef_complex^(-1)
+ END_DOC
+ integer :: k
+ do k=1, kpt_num
+   call get_inverse_complex(ao_ortho_canonical_coef_kpts,size(ao_ortho_canonical_coef_kpts,1),&
+     ao_num_per_kpt, ao_ortho_cano_coef_inv_kpts, size(ao_ortho_cano_coef_inv_kpts,1))
+ enddo
+END_PROVIDER
+
+ BEGIN_PROVIDER [ complex*16, ao_ortho_canonical_coef_kpts, (ao_num_per_kpt,ao_num_per_kpt,kpt_num)]
+&BEGIN_PROVIDER [ integer, ao_ortho_canonical_num_per_kpt, (kpt_num) ]
+&BEGIN_PROVIDER [ integer, ao_ortho_canonical_num_per_kpt_max ]
+  implicit none
+  BEGIN_DOC
+! TODO: ao_ortho_canonical_num_complex should be the same as the real version
+!       maybe if the providers weren't linked we could avoid making a complex one?
+! matrix of the coefficients of the mos generated by the
+! orthonormalization by the S^{-1/2} canonical transformation of the aos
+! ao_ortho_canonical_coef(i,j) = coefficient of the ith ao on the jth ao_ortho_canonical orbital
+  END_DOC
+  integer :: i,k
+  ao_ortho_canonical_coef_kpts = (0.d0,0.d0)
+  do k=1,kpt_num
+    do i=1,ao_num
+      ao_ortho_canonical_coef_kpts(i,i,k) = (1.d0,0.d0)
+    enddo
+  enddo
+
+!call ortho_lowdin(ao_overlap,size(ao_overlap,1),ao_num,ao_ortho_canonical_coef,size(ao_ortho_canonical_coef,1),ao_num)
+!ao_ortho_canonical_num=ao_num
+!return
+
+  if (ao_cartesian) then
+
+    ao_ortho_canonical_num_per_kpt = ao_num_per_kpt
+    do k=1,kpt_num
+      call ortho_canonical_complex(ao_overlap_kpts(:,:,k),size(ao_overlap_kpts,1), &
+        ao_num_per_kpt,ao_ortho_canonical_coef_kpts(:,:,k),size(ao_ortho_canonical_coef_kpts,1), &
+        ao_ortho_canonical_num_per_kpt(k))
+    enddo
+
+
+  else
+
+    complex*16, allocatable :: S(:,:)
+
+    allocate(S(ao_cart_to_sphe_num_per_kpt,ao_cart_to_sphe_num_per_kpt))
+    do k=1,kpt_num
+      S = (0.d0,0.d0)
+      do i=1,ao_cart_to_sphe_num_per_kpt
+        S(i,i) = (1.d0,0.d0)
+      enddo
+
+      ao_ortho_canonical_num_per_kpt(k) = ao_cart_to_sphe_num_per_kpt
+      call ortho_canonical_complex(ao_cart_to_sphe_overlap_kpts, size(ao_cart_to_sphe_overlap_kpts,1), &
+        ao_cart_to_sphe_num_per_kpt, S, size(S,1), ao_ortho_canonical_num_per_kpt(k))
+
+      call zgemm('N','N', ao_num_per_kpt, ao_ortho_canonical_num_per_kpt(k), ao_cart_to_sphe_num_per_kpt, (1.d0,0.d0), &
+        ao_cart_to_sphe_coef_kpts, size(ao_cart_to_sphe_coef_kpts,1), &
+        S, size(S,1), &
+        (0.d0,0.d0), ao_ortho_canonical_coef_kpts(:,:,k), size(ao_ortho_canonical_coef_kpts,1))
+    enddo
+
+    deallocate(S)
+  endif
+  ao_ortho_canonical_num_per_kpt_max = maxval(ao_ortho_canonical_num_per_kpt)
+END_PROVIDER
+
+BEGIN_PROVIDER [complex*16, ao_ortho_canonical_overlap_kpts, (ao_ortho_canonical_num_per_kpt_max,ao_ortho_canonical_num_per_kpt_max,kpt_num)]
+  implicit none
+  BEGIN_DOC
+! overlap matrix of the ao_ortho_canonical.
+! Expected to be the Identity
+  END_DOC
+  integer                        :: i,j,k,l,kk
+  complex*16               :: c
+  do k=1,kpt_num
+    do j=1, ao_ortho_canonical_num_per_kpt_max
+      do i=1, ao_ortho_canonical_num_per_kpt_max
+        ao_ortho_canonical_overlap_kpts(i,j,k) = (0.d0,0.d0)
+      enddo
+    enddo
+  enddo
+  do kk=1,kpt_num
+    do j=1, ao_ortho_canonical_num_per_kpt(kk)
+      do k=1, ao_num_per_kpt
+        c = (0.d0,0.d0)
+        do l=1, ao_num_per_kpt
+          c +=  conjg(ao_ortho_canonical_coef_kpts(l,j,kk)) * ao_overlap_kpts(l,k,kk)
+        enddo
+        do i=1, ao_ortho_canonical_num_per_kpt(kk)
+          ao_ortho_canonical_overlap_kpts(i,j,kk) += ao_ortho_canonical_coef_kpts(k,i,kk) * c
+        enddo
+      enddo
+    enddo
+  enddo
+END_PROVIDER

src/ao_one_e_ints/ao_overlap.irp.f

@@ -70,6 +70,59 @@
 
 END_PROVIDER
 
+!BEGIN_PROVIDER [ double precision, ao_overlap_imag, (ao_num, ao_num) ]
+! implicit none
+! BEGIN_DOC
+! ! Imaginary part of the overlap
+! END_DOC
+!  if (read_ao_integrals_overlap) then
+!     call ezfio_get_ao_one_e_ints_ao_integrals_overlap_imag(ao_overlap_imag(1:ao_num, 1:ao_num))
+!     print *,  'AO overlap integrals read from disk'
+!  else
+!    ao_overlap_imag = 0.d0
+!  endif
+!  if (write_ao_integrals_overlap) then
+!     call ezfio_set_ao_one_e_ints_ao_integrals_overlap_imag(ao_overlap_imag(1:ao_num, 1:ao_num))
+!     print *,  'AO overlap integrals written to disk'
+!  endif
+!END_PROVIDER
+
+BEGIN_PROVIDER [ complex*16, ao_overlap_complex, (ao_num, ao_num) ]
+  implicit none
+  BEGIN_DOC
+  ! Overlap for complex AOs
+  END_DOC
+  if (read_ao_integrals_overlap) then
+    call ezfio_get_ao_one_e_ints_ao_integrals_overlap_complex(ao_overlap_complex)
+    print *,  'AO overlap integrals read from disk'
+  else
+    print*,'complex AO overlap ints must be provided',irp_here
+  endif
+  if (write_ao_integrals_overlap) then
+     call ezfio_set_ao_one_e_ints_ao_integrals_overlap_complex(ao_overlap_complex)
+     print *,  'AO overlap integrals written to disk'
+  endif
+END_PROVIDER
+
+BEGIN_PROVIDER [ complex*16, ao_overlap_kpts, (ao_num_per_kpt, ao_num_per_kpt, kpt_num) ]
+  implicit none
+  BEGIN_DOC
+  ! Overlap for complex AOs
+  END_DOC
+  if (read_ao_integrals_overlap) then
+    call ezfio_get_ao_one_e_ints_ao_integrals_overlap_kpts(ao_overlap_kpts)
+    print *,  'AO overlap integrals read from disk'
+  else
+    print*,'complex AO overlap ints must be provided',irp_here
+  endif
+  if (write_ao_integrals_overlap) then
+     call ezfio_set_ao_one_e_ints_ao_integrals_overlap_kpts(ao_overlap_kpts)
+     print *,  'AO overlap integrals written to disk'
+  endif
+END_PROVIDER
+
+
+
 
 BEGIN_PROVIDER [ double precision, ao_overlap_abs,(ao_num,ao_num) ]
   implicit none
@@ -86,44 +139,57 @@ BEGIN_PROVIDER [ double precision, ao_overlap_abs,(ao_num,ao_num) ]
   double precision :: A_center(3), B_center(3)
   integer :: power_A(3), power_B(3)
   double precision :: lower_exp_val, dx
-  dim1=100
-  lower_exp_val = 40.d0
-  !$OMP PARALLEL DO SCHEDULE(GUIDED) &
-  !$OMP DEFAULT(NONE) &
-  !$OMP PRIVATE(A_center,B_center,power_A,power_B,&
-  !$OMP  overlap_x,overlap_y, overlap_z, overlap, &
-  !$OMP  alpha, beta,i,j,dx) &
-  !$OMP SHARED(nucl_coord,ao_power,ao_prim_num, &
-  !$OMP  ao_overlap_abs,ao_num,ao_coef_normalized_ordered_transp,ao_nucl, &
-  !$OMP  ao_expo_ordered_transp,dim1,lower_exp_val)
-  do j=1,ao_num
-   A_center(1) = nucl_coord( ao_nucl(j), 1 )
-   A_center(2) = nucl_coord( ao_nucl(j), 2 )
-   A_center(3) = nucl_coord( ao_nucl(j), 3 )
-   power_A(1)  = ao_power( j, 1 )
-   power_A(2)  = ao_power( j, 2 )
-   power_A(3)  = ao_power( j, 3 )
-   do i= 1,ao_num
-    ao_overlap_abs(i,j)= 0.d0
-    B_center(1) = nucl_coord( ao_nucl(i), 1 )
-    B_center(2) = nucl_coord( ao_nucl(i), 2 )
-    B_center(3) = nucl_coord( ao_nucl(i), 3 )
-    power_B(1)  = ao_power( i, 1 )
-    power_B(2)  = ao_power( i, 2 )
-    power_B(3)  = ao_power( i, 3 )
-    do n = 1,ao_prim_num(j)
-     alpha = ao_expo_ordered_transp(n,j)
-     do l = 1, ao_prim_num(i)
-      beta = ao_expo_ordered_transp(l,i)
-      call overlap_x_abs(A_center(1),B_center(1),alpha,beta,power_A(1),power_B(1),overlap_x,lower_exp_val,dx,dim1)
-      call overlap_x_abs(A_center(2),B_center(2),alpha,beta,power_A(2),power_B(2),overlap_y,lower_exp_val,dx,dim1)
-      call overlap_x_abs(A_center(3),B_center(3),alpha,beta,power_A(3),power_B(3),overlap_z,lower_exp_val,dx,dim1)
-      ao_overlap_abs(i,j) += abs(ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i)) * overlap_x * overlap_y * overlap_z
-     enddo
+  if (is_complex) then
+    ao_overlap_abs = 0.d0
+    integer :: k, ishift
+    do k=1,kpt_num
+      ishift = (k-1)*ao_num_per_kpt
+      do j=1,ao_num_per_kpt
+        do i= 1,ao_num_per_kpt
+          ao_overlap_abs(ishift+i,ishift+j)= cdabs(ao_overlap_kpts(i,j,k))
+        enddo
+      enddo
     enddo
-   enddo
-  enddo
-  !$OMP END PARALLEL DO
+  else
+    dim1=100
+    lower_exp_val = 40.d0
+    !$OMP PARALLEL DO SCHEDULE(GUIDED)                               &
+        !$OMP DEFAULT(NONE)                                          &
+        !$OMP PRIVATE(A_center,B_center,power_A,power_B,             &
+        !$OMP  overlap_x,overlap_y, overlap_z, overlap,              &
+        !$OMP  alpha, beta,i,j,dx)                                   &
+        !$OMP SHARED(nucl_coord,ao_power,ao_prim_num,                &
+        !$OMP  ao_overlap_abs,ao_num,ao_coef_normalized_ordered_transp,ao_nucl,&
+        !$OMP  ao_expo_ordered_transp,dim1,lower_exp_val)
+    do j=1,ao_num
+      A_center(1) = nucl_coord( ao_nucl(j), 1 )
+      A_center(2) = nucl_coord( ao_nucl(j), 2 )
+      A_center(3) = nucl_coord( ao_nucl(j), 3 )
+      power_A(1)  = ao_power( j, 1 )
+      power_A(2)  = ao_power( j, 2 )
+      power_A(3)  = ao_power( j, 3 )
+      do i= 1,ao_num
+        ao_overlap_abs(i,j)= 0.d0
+        B_center(1) = nucl_coord( ao_nucl(i), 1 )
+        B_center(2) = nucl_coord( ao_nucl(i), 2 )
+        B_center(3) = nucl_coord( ao_nucl(i), 3 )
+        power_B(1)  = ao_power( i, 1 )
+        power_B(2)  = ao_power( i, 2 )
+        power_B(3)  = ao_power( i, 3 )
+        do n = 1,ao_prim_num(j)
+          alpha = ao_expo_ordered_transp(n,j)
+          do l = 1, ao_prim_num(i)
+            beta = ao_expo_ordered_transp(l,i)
+            call overlap_x_abs(A_center(1),B_center(1),alpha,beta,power_A(1),power_B(1),overlap_x,lower_exp_val,dx,dim1)
+            call overlap_x_abs(A_center(2),B_center(2),alpha,beta,power_A(2),power_B(2),overlap_y,lower_exp_val,dx,dim1)
+            call overlap_x_abs(A_center(3),B_center(3),alpha,beta,power_A(3),power_B(3),overlap_z,lower_exp_val,dx,dim1)
+            ao_overlap_abs(i,j) += abs(ao_coef_normalized_ordered_transp(n,j) * ao_coef_normalized_ordered_transp(l,i)) * overlap_x * overlap_y * overlap_z
+          enddo
+        enddo
+      enddo
+    enddo
+    !$OMP END PARALLEL DO
+  endif
 END_PROVIDER
 
 BEGIN_PROVIDER [ double precision, S_inv,(ao_num,ao_num) ]
@@ -134,6 +200,27 @@ BEGIN_PROVIDER [ double precision, S_inv,(ao_num,ao_num) ]
  call get_pseudo_inverse(ao_overlap,size(ao_overlap,1),ao_num,ao_num,S_inv,size(S_inv,1))
 END_PROVIDER
 
+BEGIN_PROVIDER [ complex*16, S_inv_complex,(ao_num,ao_num) ]
+ implicit none
+ BEGIN_DOC
+! Inverse of the overlap matrix
+ END_DOC
+ call get_pseudo_inverse_complex(ao_overlap_complex, &
+    size(ao_overlap_complex,1),ao_num,ao_num,S_inv_complex,size(S_inv_complex,1))
+END_PROVIDER
+
+BEGIN_PROVIDER [ complex*16, S_inv_kpts,(ao_num_per_kpt,ao_num_per_kpt,kpt_num) ]
+ implicit none
+ BEGIN_DOC
+! Inverse of the overlap matrix
+ END_DOC
+ integer :: k
+ do k=1,kpt_num
+  call get_pseudo_inverse_complex(ao_overlap_kpts(1,1,k), &
+     size(ao_overlap_kpts,1),ao_num_per_kpt,ao_num_per_kpt,S_inv_kpts(1,1,k),size(S_inv_kpts,1))
+ enddo
+END_PROVIDER
+
 BEGIN_PROVIDER [ double precision, S_half_inv, (AO_num,AO_num) ]
 
   BEGIN_DOC
@@ -192,6 +279,125 @@ BEGIN_PROVIDER [ double precision, S_half_inv, (AO_num,AO_num) ]
 
 END_PROVIDER
 
+BEGIN_PROVIDER [ complex*16, S_half_inv_complex, (AO_num,AO_num) ]
+
+  BEGIN_DOC
+!   :math:`X = S^{-1/2}` obtained by SVD
+  END_DOC
+
+  implicit none
+
+  integer                         :: num_linear_dependencies
+  integer                         :: LDA, LDC
+  double precision, allocatable   :: D(:)
+  complex*16, allocatable   :: U(:,:),Vt(:,:)
+  integer                         :: info, i, j, k
+  double precision, parameter     :: threshold_overlap_AO_eigenvalues = 1.d-6
+
+  LDA = size(AO_overlap_complex,1)
+  LDC = size(S_half_inv_complex,1)
+
+  allocate(         &
+    U(LDC,AO_num),  &
+    Vt(LDA,AO_num), &
+    D(AO_num))
+
+  call svd_complex(    &
+       ao_overlap_complex,LDA, &
+       U,LDC,          &
+       D,              &
+       Vt,LDA,         &
+       AO_num,AO_num)
+
+  num_linear_dependencies = 0
+  do i=1,AO_num
+    print*,D(i)
+    if(abs(D(i)) <= threshold_overlap_AO_eigenvalues) then
+      D(i) = 0.d0
+      num_linear_dependencies += 1
+    else
+      ASSERT (D(i) > 0.d0)
+      D(i) = 1.d0/sqrt(D(i))
+    endif
+    do j=1,AO_num
+      S_half_inv_complex(j,i) = 0.d0
+    enddo
+  enddo
+  write(*,*) 'linear dependencies',num_linear_dependencies
+
+  do k=1,AO_num
+    if(D(k) /= 0.d0) then
+      do j=1,AO_num
+        do i=1,AO_num
+          S_half_inv_complex(i,j) = S_half_inv_complex(i,j) + U(i,k)*D(k)*Vt(k,j)
+        enddo
+      enddo
+    endif
+  enddo
+
+
+END_PROVIDER
+
+BEGIN_PROVIDER [ complex*16, S_half_inv_kpts, (ao_num_per_kpt,ao_num_per_kpt,kpt_num) ]
+
+  BEGIN_DOC
+!   :math:`X = S^{-1/2}` obtained by SVD
+  END_DOC
+
+  implicit none
+
+  integer                         :: num_linear_dependencies
+  integer                         :: LDA, LDC
+  double precision, allocatable   :: D(:)
+  complex*16, allocatable   :: U(:,:),Vt(:,:)
+  integer                         :: info, i, j, k,kk
+  double precision, parameter     :: threshold_overlap_AO_eigenvalues = 1.d-6
+
+  LDA = size(ao_overlap_kpts,1)
+  LDC = size(s_half_inv_kpts,1)
+
+  allocate(         &
+    U(LDC,ao_num_per_kpt),  &
+    Vt(LDA,ao_num_per_kpt), &
+    D(ao_num_per_kpt))
+  
+  do kk=1,kpt_num
+    call svd_complex(    &
+         ao_overlap_kpts(1,1,kk),LDA, &
+         U,LDC,          &
+         D,              &
+         Vt,LDA,         &
+         ao_num_per_kpt,ao_num_per_kpt)
+  
+    num_linear_dependencies = 0
+    do i=1,ao_num_per_kpt
+      print*,D(i)
+      if(abs(D(i)) <= threshold_overlap_AO_eigenvalues) then
+        D(i) = 0.d0
+        num_linear_dependencies += 1
+      else
+        ASSERT (D(i) > 0.d0)
+        D(i) = 1.d0/sqrt(D(i))
+      endif
+      do j=1,ao_num_per_kpt
+        S_half_inv_kpts(j,i,kk) = 0.d0
+      enddo
+    enddo
+    write(*,*) 'linear dependencies, k: ',num_linear_dependencies,', ',kk 
+  
+    do k=1,ao_num_per_kpt
+      if(D(k) /= 0.d0) then
+        do j=1,ao_num_per_kpt
+          do i=1,ao_num_per_kpt
+            S_half_inv_kpts(i,j,kk) = S_half_inv_kpts(i,j,kk) + U(i,k)*D(k)*Vt(k,j)
+          enddo
+        enddo
+      endif
+    enddo
+  enddo
+
+END_PROVIDER
+
 
 BEGIN_PROVIDER [ double precision, S_half, (ao_num,ao_num)  ]
  implicit none
@@ -227,3 +433,73 @@ BEGIN_PROVIDER [ double precision, S_half, (ao_num,ao_num)  ]
 
 END_PROVIDER
 
+BEGIN_PROVIDER [ complex*16, S_half_complex, (ao_num,ao_num)  ]
+ implicit none
+ BEGIN_DOC
+ ! :math:`S^{1/2}`
+ END_DOC
+
+  integer :: i,j,k
+  complex*16, allocatable  :: U(:,:)
+  complex*16, allocatable  :: Vt(:,:)
+  double precision, allocatable  :: D(:)
+
+  allocate(U(ao_num,ao_num),Vt(ao_num,ao_num),D(ao_num))
+
+  call svd_complex(ao_overlap_complex,size(ao_overlap_complex,1),U,size(U,1),D,Vt,size(Vt,1),ao_num,ao_num)
+
+  do i=1,ao_num
+    D(i) = dsqrt(D(i))
+    do j=1,ao_num
+      S_half_complex(j,i) = (0.d0,0.d0)
+    enddo
+  enddo
+
+  do k=1,ao_num
+      do j=1,ao_num
+        do i=1,ao_num
+          S_half_complex(i,j) = S_half_complex(i,j) + U(i,k)*D(k)*Vt(k,j)
+        enddo
+      enddo
+  enddo
+
+  deallocate(U,Vt,D)
+
+END_PROVIDER
+
+BEGIN_PROVIDER [ complex*16, S_half_kpts, (ao_num_per_kpt,ao_num_per_kpt,kpt_num)  ]
+ implicit none
+ BEGIN_DOC
+ ! :math:`S^{1/2}`
+ END_DOC
+
+  integer :: i,j,k,kk
+  complex*16, allocatable  :: U(:,:)
+  complex*16, allocatable  :: Vt(:,:)
+  double precision, allocatable  :: D(:)
+
+  allocate(U(ao_num_per_kpt,ao_num_per_kpt),Vt(ao_num_per_kpt,ao_num_per_kpt),D(ao_num_per_kpt))
+
+  do kk=1,kpt_num
+    call svd_complex(ao_overlap_kpts(1,1,k),size(ao_overlap_kpts,1),U,size(U,1),D,Vt,size(Vt,1),ao_num_per_kpt,ao_num_per_kpt)
+  
+    do i=1,ao_num_per_kpt
+      D(i) = dsqrt(D(i))
+      do j=1,ao_num_per_kpt
+        S_half_kpts(j,i,kk) = (0.d0,0.d0)
+      enddo
+    enddo
+  
+    do k=1,ao_num_per_kpt
+        do j=1,ao_num_per_kpt
+          do i=1,ao_num_per_kpt
+            S_half_kpts(i,j,kk) = S_half_kpts(i,j,kk) + U(i,k)*D(k)*Vt(k,j)
+          enddo
+        enddo
+    enddo
+  enddo
+
+  deallocate(U,Vt,D)
+
+END_PROVIDER
+

src/ao_one_e_ints/kin_ao_ints.irp.f

@@ -149,3 +149,66 @@ BEGIN_PROVIDER [double precision, ao_kinetic_integrals, (ao_num,ao_num)]
   endif
 END_PROVIDER
 
+!BEGIN_PROVIDER [double precision, ao_kinetic_integrals_imag, (ao_num,ao_num)]
+!  implicit none
+!  BEGIN_DOC
+!  ! Kinetic energy integrals in the |AO| basis.
+!  !
+!  ! $\langle \chi_i |\hat{T}| \chi_j \rangle$
+!  !
+!  END_DOC
+!  integer                        :: i,j,k,l
+!
+!  if (read_ao_integrals_kinetic) then
+!    call ezfio_get_ao_one_e_ints_ao_integrals_kinetic_imag(ao_kinetic_integrals_imag)
+!    print *,  'AO kinetic integrals read from disk'
+!  else
+!    print *,  irp_here, ': Not yet implemented'
+!  endif
+!  if (write_ao_integrals_kinetic) then
+!    call ezfio_set_ao_one_e_ints_ao_integrals_kinetic_imag(ao_kinetic_integrals_imag)
+!    print *,  'AO kinetic integrals written to disk'
+!  endif
+!END_PROVIDER
+
+BEGIN_PROVIDER [complex*16, ao_kinetic_integrals_complex, (ao_num,ao_num)]
+  implicit none
+  BEGIN_DOC
+  ! Kinetic energy integrals in the |AO| basis.
+  !
+  ! $\langle \chi_i |\hat{T}| \chi_j \rangle$
+  !
+  END_DOC
+  if (read_ao_integrals_kinetic) then
+    call ezfio_get_ao_one_e_ints_ao_integrals_kinetic_complex(ao_kinetic_integrals_complex)
+    print *,  'AO kinetic integrals read from disk'
+  else
+    print *,  irp_here, ': Not yet implemented'
+    stop -1
+  endif
+  if (write_ao_integrals_kinetic) then
+    call ezfio_set_ao_one_e_ints_ao_integrals_kinetic_complex(ao_kinetic_integrals_complex)
+    print *,  'AO kinetic integrals written to disk'
+  endif
+END_PROVIDER
+
+BEGIN_PROVIDER [complex*16, ao_kinetic_integrals_kpts, (ao_num_per_kpt,ao_num_per_kpt,kpt_num)]
+  implicit none
+  BEGIN_DOC
+  ! Kinetic energy integrals in the |AO| basis.
+  !
+  ! $\langle \chi_i |\hat{T}| \chi_j \rangle$
+  !
+  END_DOC
+  if (read_ao_integrals_kinetic) then
+    call ezfio_get_ao_one_e_ints_ao_integrals_kinetic_kpts(ao_kinetic_integrals_kpts)
+    print *,  'AO kinetic integrals read from disk'
+  else
+    print *,  irp_here, ': Not yet implemented'
+    stop -1
+  endif
+  if (write_ao_integrals_kinetic) then
+    call ezfio_set_ao_one_e_ints_ao_integrals_kinetic_kpts(ao_kinetic_integrals_kpts)
+    print *,  'AO kinetic integrals written to disk'
+  endif
+END_PROVIDER

src/ao_one_e_ints/pot_ao_ints.irp.f

@@ -12,8 +12,8 @@ BEGIN_PROVIDER [ double precision, ao_integrals_n_e, (ao_num,ao_num)]
   integer                        :: i,j,k,l,n_pt_in,m
   double precision               :: overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult
 
-  if (read_ao_integrals_e_n) then
-    call ezfio_get_ao_one_e_ints_ao_integrals_e_n(ao_integrals_n_e)
+  if (read_ao_integrals_n_e) then
+    call ezfio_get_ao_one_e_ints_ao_integrals_n_e(ao_integrals_n_e)
     print *,  'AO N-e integrals read from disk'
   else
 
@@ -76,13 +76,69 @@ BEGIN_PROVIDER [ double precision, ao_integrals_n_e, (ao_num,ao_num)]
     !$OMP END DO
     !$OMP END PARALLEL
   endif
-  if (write_ao_integrals_e_n) then
-    call ezfio_set_ao_one_e_ints_ao_integrals_e_n(ao_integrals_n_e)
+  if (write_ao_integrals_n_e) then
+    call ezfio_set_ao_one_e_ints_ao_integrals_n_e(ao_integrals_n_e)
     print *,  'AO N-e integrals written to disk'
   endif
 
 END_PROVIDER
 
+!BEGIN_PROVIDER [ double precision, ao_integrals_n_e_imag, (ao_num,ao_num)]
+!  BEGIN_DOC
+!  !  Nucleus-electron interaction, in the |AO| basis set.
+!  !
+!  !  :math:`\langle \chi_i | -\sum_A \frac{1}{|r-R_A|} | \chi_j \rangle`
+!  END_DOC
+!  implicit none
+!  double precision               :: alpha, beta, gama, delta
+!  integer                        :: num_A,num_B
+!  double precision               :: A_center(3),B_center(3),C_center(3)
+!  integer                        :: power_A(3),power_B(3)
+!  integer                        :: i,j,k,l,n_pt_in,m
+!  double precision               :: overlap_x,overlap_y,overlap_z,overlap,dx,NAI_pol_mult
+!
+!  if (read_ao_integrals_n_e) then
+!    call ezfio_get_ao_one_e_ints_ao_integrals_n_e_imag(ao_integrals_n_e_imag)
+!    print *,  'AO N-e integrals read from disk'
+!  else
+!   print *,  irp_here, ': Not yet implemented'
+!  endif
+!END_PROVIDER
+
+BEGIN_PROVIDER [complex*16, ao_integrals_n_e_complex, (ao_num,ao_num)]
+  implicit none
+  BEGIN_DOC
+  !  Nucleus-electron interaction, in the |AO| basis set.
+  !
+  !  :math:`\langle \chi_i | -\sum_A \frac{1}{|r-R_A|} | \chi_j \rangle`
+  END_DOC
+  print*,'error: ',irp_here
+  write(*,*) "test"
+  ao_integrals_n_e_complex(999,999) = 0.d0
+  call abort()
+  if (read_ao_integrals_n_e) then
+    call ezfio_get_ao_one_e_ints_ao_integrals_n_e_complex(ao_integrals_n_e_complex)
+    print *,  'AO N-e integrals read from disk'
+  else
+   print *,  irp_here, ': Not yet implemented'
+  endif
+END_PROVIDER
+
+BEGIN_PROVIDER [complex*16, ao_integrals_n_e_kpts, (ao_num_per_kpt,ao_num_per_kpt,kpt_num)]
+  implicit none
+  BEGIN_DOC
+  !  Nucleus-electron interaction, in the |AO| basis set.
+  !
+  !  :math:`\langle \chi_i | -\sum_A \frac{1}{|r-R_A|} | \chi_j \rangle`
+  END_DOC
+  if (read_ao_integrals_n_e) then
+    call ezfio_get_ao_one_e_ints_ao_integrals_n_e_kpts(ao_integrals_n_e_kpts)
+    print *,  'AO N-e integrals read from disk'
+  else
+   print *,  irp_here, ': Not yet implemented'
+  endif
+END_PROVIDER
+
 BEGIN_PROVIDER [ double precision, ao_integrals_n_e_per_atom, (ao_num,ao_num,nucl_num)]
   BEGIN_DOC
 ! Nucleus-electron interaction in the |AO| basis set, per atom A.
@@ -166,7 +222,7 @@ double precision function NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,b
   double precision               :: P_center(3)
   double precision               :: d(0:n_pt_in),pouet,coeff,rho,dist,const,pouet_2,p,p_inv,factor
   double precision               :: I_n_special_exact,integrate_bourrin,I_n_bibi
-  double precision               :: V_e_n,const_factor,dist_integral,tmp
+  double precision               :: V_n_e,const_factor,dist_integral,tmp
   double precision               :: accu,epsilo,rint
   integer                        :: n_pt_out,lmax
   include 'utils/constants.include.F'
@@ -178,7 +234,7 @@ double precision function NAI_pol_mult(A_center,B_center,power_A,power_B,alpha,b
         (A_center(3)/=C_center(3))) then
     continue
   else
-    NAI_pol_mult = V_e_n(power_A(1),power_A(2),power_A(3),           &
+    NAI_pol_mult = V_n_e(power_A(1),power_A(2),power_A(3),           &
         power_B(1),power_B(2),power_B(3),alpha,beta)
     return
   endif
@@ -476,7 +532,7 @@ recursive subroutine I_x2_pol_mult_one_e(c,R1x,R1xp,R2x,d,nd,dim)
   endif
 end
 
-double precision function V_e_n(a_x,a_y,a_z,b_x,b_y,b_z,alpha,beta)
+double precision function V_n_e(a_x,a_y,a_z,b_x,b_y,b_z,alpha,beta)
   implicit none
   BEGIN_DOC
 ! Primitve nuclear attraction between the two primitves centered on the same atom.
@@ -489,9 +545,9 @@ double precision function V_e_n(a_x,a_y,a_z,b_x,b_y,b_z,alpha,beta)
   double precision               :: alpha,beta
   double precision               :: V_r, V_phi, V_theta
   if(iand((a_x+b_x),1)==1.or.iand(a_y+b_y,1)==1.or.iand((a_z+b_z),1)==1)then
-    V_e_n = 0.d0
+    V_n_e = 0.d0
   else
-    V_e_n =   V_r(a_x+b_x+a_y+b_y+a_z+b_z+1,alpha+beta)              &
+    V_n_e =   V_r(a_x+b_x+a_y+b_y+a_z+b_z+1,alpha+beta)              &
         * V_phi(a_x+b_x,a_y+b_y)                                     &
         * V_theta(a_z+b_z,a_x+b_x+a_y+b_y+1)
   endif

src/ao_one_e_ints/pot_ao_pseudo_ints.irp.f

@@ -27,6 +27,59 @@ BEGIN_PROVIDER [ double precision, ao_pseudo_integrals, (ao_num,ao_num)]
 
 END_PROVIDER
 
+!BEGIN_PROVIDER [ double precision, ao_pseudo_integrals_imag, (ao_num, ao_num) ]
+! implicit none
+! BEGIN_DOC
+! ! Imaginary part of the pseudo_integrals
+! END_DOC
+!  if (read_ao_integrals_pseudo) then
+!     call ezfio_get_ao_one_e_ints_ao_integrals_pseudo_imag(ao_pseudo_integrals_imag(1:ao_num, 1:ao_num))
+!     print *,  'AO pseudo_integrals integrals read from disk'
+!  else
+!    ao_pseudo_integrals_imag = 0.d0
+!  endif
+!  if (write_ao_integrals_pseudo) then
+!     call ezfio_set_ao_one_e_ints_ao_integrals_pseudo_imag(ao_pseudo_integrals_imag(1:ao_num, 1:ao_num))
+!     print *,  'AO pseudo_integrals integrals written to disk'
+!  endif
+!END_PROVIDER
+
+BEGIN_PROVIDER [ complex*16, ao_pseudo_integrals_complex, (ao_num, ao_num) ]
+  implicit none
+  BEGIN_DOC
+  ! Overlap for complex AOs
+  END_DOC
+  if (read_ao_integrals_pseudo) then
+     call ezfio_get_ao_one_e_ints_ao_integrals_pseudo_complex(ao_pseudo_integrals_complex)
+     print *,  'AO pseudo_integrals integrals read from disk'
+  else
+    print*,irp_here,'not implemented'
+    stop -1
+  endif
+  if (write_ao_integrals_pseudo) then
+     call ezfio_set_ao_one_e_ints_ao_integrals_pseudo_complex(ao_pseudo_integrals_complex)
+     print *,  'AO pseudo_integrals integrals written to disk'
+  endif
+END_PROVIDER
+
+BEGIN_PROVIDER [ complex*16, ao_pseudo_integrals_kpts, (ao_num_per_kpt, ao_num_per_kpt, kpt_num) ]
+  implicit none
+  BEGIN_DOC
+  ! Overlap for complex AOs
+  END_DOC
+  if (read_ao_integrals_pseudo) then
+     call ezfio_get_ao_one_e_ints_ao_integrals_pseudo_kpts(ao_pseudo_integrals_kpts)
+     print *,  'AO pseudo_integrals integrals read from disk'
+  else
+    print*,irp_here,'not implemented'
+    stop -1
+  endif
+  if (write_ao_integrals_pseudo) then
+     call ezfio_set_ao_one_e_ints_ao_integrals_pseudo_kpts(ao_pseudo_integrals_kpts)
+     print *,  'AO pseudo_integrals integrals written to disk'
+  endif
+END_PROVIDER
+
 BEGIN_PROVIDER [ double precision, ao_pseudo_integrals_local, (ao_num,ao_num)]
   implicit none
   BEGIN_DOC

src/ao_two_e_ints/EZFIO.cfg

@@ -18,3 +18,20 @@ interface: ezfio,provider,ocaml
 default: False
 ezfio_name: direct
 
+[df_num]
+type: integer
+doc: Size of df basis
+interface: ezfio, provider
+
+[io_df_ao_integrals]
+type: Disk_access
+doc: Read/Write df |AO| integrals from/to disk [ Write | Read | None ] 
+interface: ezfio,provider,ocaml
+default: None
+
+[df_ao_integrals_complex]
+type: double precision
+doc: Real part of the df integrals over AOs
+size: (2,ao_basis.ao_num_per_kpt,ao_basis.ao_num_per_kpt,ao_two_e_ints.df_num,nuclei.kpt_pair_num)
+interface: ezfio
+

src/ao_two_e_ints/df_ao_ints.irp.f

@@ -0,0 +1,233 @@
+BEGIN_PROVIDER [complex*16, df_ao_integrals_complex, (ao_num_per_kpt,ao_num_per_kpt,df_num,kpt_pair_num)]
+  implicit none
+  BEGIN_DOC
+  !  df AO integrals
+  END_DOC
+  integer :: i,j,k,l
+
+  if (read_df_ao_integrals) then
+    call ezfio_get_ao_two_e_ints_df_ao_integrals_complex(df_ao_integrals_complex)
+    print *,  'df AO integrals read from disk'
+  else
+    print*,'df ao integrals must be provided',irp_here
+    stop -1
+  endif
+
+  if (write_df_ao_integrals) then
+    call ezfio_set_ao_two_e_ints_df_ao_integrals_complex(df_ao_integrals_complex)
+    print *,  'df AO integrals written to disk'
+  endif
+
+END_PROVIDER
+
+
+subroutine ao_map_fill_from_df
+  use map_module
+  implicit none
+  BEGIN_DOC
+  ! fill ao bielec integral map using 3-index df integrals
+  END_DOC
+
+  integer :: i,k,j,l
+  integer :: ki,kk,kj,kl
+  integer :: ii,ik,ij,il
+  integer :: kikk2,kjkl2,jl2,ik2
+  integer :: i_ao,j_ao,i_df
+
+  complex*16,allocatable :: ints_ik(:,:,:), ints_jl(:,:,:), ints_ikjl(:,:,:,:)
+
+  complex*16 :: integral
+  integer                        :: n_integrals_1, n_integrals_2
+  integer                        :: size_buffer
+  integer(key_kind),allocatable  :: buffer_i_1(:), buffer_i_2(:)
+  real(integral_kind),allocatable :: buffer_values_1(:), buffer_values_2(:)
+  double precision               :: tmp_re,tmp_im
+  integer                        :: ao_num_kpt_2
+
+  double precision               :: cpu_1, cpu_2, wall_1, wall_2, wall_0
+  double precision               :: map_mb
+
+  logical :: use_map1
+  integer(keY_kind) :: idx_tmp
+  double precision :: sign
+
+  ao_num_kpt_2 = ao_num_per_kpt * ao_num_per_kpt
+
+  size_buffer = min(ao_num_per_kpt*ao_num_per_kpt*ao_num_per_kpt,16000000)
+  print*, 'Providing the ao_bielec integrals from 3-index df integrals'
+  call write_time(6)
+!  call ezfio_set_integrals_bielec_disk_access_mo_integrals('Write')
+!  TOUCH read_mo_integrals read_ao_integrals write_mo_integrals write_ao_integrals 
+
+  call wall_time(wall_1)
+  call cpu_time(cpu_1)
+
+  allocate( ints_jl(ao_num_per_kpt,ao_num_per_kpt,df_num))
+
+  wall_0 = wall_1
+  do kl=1, kpt_num
+    do kj=1, kl
+      call idx2_tri_int(kj,kl,kjkl2)
+      if (kj < kl) then
+        do i_ao=1,ao_num_per_kpt
+          do j_ao=1,ao_num_per_kpt
+            do i_df=1,df_num
+              ints_jl(i_ao,j_ao,i_df) = dconjg(df_ao_integrals_complex(j_ao,i_ao,i_df,kjkl2))
+            enddo
+          enddo
+        enddo
+      else
+        ints_jl = df_ao_integrals_complex(:,:,:,kjkl2)
+      endif
+
+  !$OMP PARALLEL PRIVATE(i,k,j,l,ki,kk,ii,ik,ij,il,kikk2,jl2,ik2, &
+      !$OMP  ints_ik, ints_ikjl, i_ao, j_ao, i_df, &
+      !$OMP  n_integrals_1, buffer_i_1, buffer_values_1, &
+      !$OMP  n_integrals_2, buffer_i_2, buffer_values_2, &
+      !$OMP  idx_tmp, tmp_re, tmp_im, integral,sign,use_map1) &
+      !$OMP  DEFAULT(NONE)  &
+      !$OMP  SHARED(size_buffer, kpt_num, df_num, ao_num_per_kpt, ao_num_kpt_2, &
+      !$OMP  kl,kj,kjkl2,ints_jl, & 
+      !$OMP  kconserv, df_ao_integrals_complex, ao_integrals_threshold, ao_integrals_map, ao_integrals_map_2)
+  
+  allocate( &
+    ints_ik(ao_num_per_kpt,ao_num_per_kpt,df_num), &
+    ints_ikjl(ao_num_per_kpt,ao_num_per_kpt,ao_num_per_kpt,ao_num_per_kpt), &
+    buffer_i_1(size_buffer), &
+    buffer_i_2(size_buffer), &
+    buffer_values_1(size_buffer), &
+    buffer_values_2(size_buffer) &
+  )
+
+  !$OMP DO SCHEDULE(guided)
+      do kk=1,kl
+        ki=kconserv(kl,kk,kj)
+        if (ki>kl) cycle
+      !  if ((kl == kj) .and. (ki > kk)) cycle
+        call idx2_tri_int(ki,kk,kikk2)
+      !  if (kikk2 > kjkl2) cycle
+        if (ki < kk) then
+          do i_ao=1,ao_num_per_kpt
+            do j_ao=1,ao_num_per_kpt
+              do i_df=1,df_num
+                ints_ik(i_ao,j_ao,i_df) = dconjg(df_ao_integrals_complex(j_ao,i_ao,i_df,kikk2))
+              enddo
+            enddo
+          enddo
+!          ints_ik = conjg(reshape(df_mo_integral_array(:,:,:,kikk2),(/mo_num_per_kpt,mo_num_per_kpt,df_num/),order=(/2,1,3/)))
+        else
+          ints_ik = df_ao_integrals_complex(:,:,:,kikk2)
+        endif
+
+        call zgemm('N','T', ao_num_kpt_2, ao_num_kpt_2, df_num, &
+               (1.d0,0.d0), ints_ik, ao_num_kpt_2, &
+               ints_jl, ao_num_kpt_2, &
+               (0.d0,0.d0), ints_ikjl, ao_num_kpt_2)
+
+        n_integrals_1=0
+        n_integrals_2=0
+        do il=1,ao_num_per_kpt
+          l=il+(kl-1)*ao_num_per_kpt
+          do ij=1,ao_num_per_kpt
+            j=ij+(kj-1)*ao_num_per_kpt
+            if (j>l) exit
+            call idx2_tri_int(j,l,jl2)
+            do ik=1,ao_num_per_kpt
+              k=ik+(kk-1)*ao_num_per_kpt
+              if (k>l) exit
+              do ii=1,ao_num_per_kpt
+                i=ii+(ki-1)*ao_num_per_kpt
+                if ((j==l) .and. (i>k)) exit
+                call idx2_tri_int(i,k,ik2)
+                if (ik2 > jl2) exit
+                integral = ints_ikjl(ii,ik,ij,il)
+!                print*,i,k,j,l,real(integral),imag(integral)
+                if (cdabs(integral) < ao_integrals_threshold) then
+                  cycle
+                endif
+                call ao_two_e_integral_complex_map_idx_sign(i,j,k,l,use_map1,idx_tmp,sign)
+                tmp_re = dble(integral)
+                tmp_im = dimag(integral)
+                if (use_map1) then
+                  n_integrals_1 += 1
+                  buffer_i_1(n_integrals_1)=idx_tmp
+                  buffer_values_1(n_integrals_1)=tmp_re
+                  if (sign.ne.0.d0) then 
+                    n_integrals_1 += 1
+                    buffer_i_1(n_integrals_1)=idx_tmp+1
+                    buffer_values_1(n_integrals_1)=tmp_im*sign
+                  endif 
+                  if (n_integrals_1 >= size(buffer_i_1)-1) then
+                    call insert_into_ao_integrals_map(n_integrals_1,buffer_i_1,buffer_values_1)
+                    n_integrals_1 = 0
+                  endif
+                else
+                  n_integrals_2 += 1
+                  buffer_i_2(n_integrals_2)=idx_tmp
+                  buffer_values_2(n_integrals_2)=tmp_re
+                  if (sign.ne.0.d0) then
+                    n_integrals_2 += 1
+                    buffer_i_2(n_integrals_2)=idx_tmp+1
+                    buffer_values_2(n_integrals_2)=tmp_im*sign
+                  endif 
+                  if (n_integrals_2 >= size(buffer_i_2)-1) then
+                    call insert_into_ao_integrals_map_2(n_integrals_2,buffer_i_2,buffer_values_2)
+                    n_integrals_2 = 0
+                  endif
+                endif
+
+              enddo !ii
+            enddo !ik
+          enddo !ij
+        enddo !il
+
+        if (n_integrals_1 > 0) then
+          call insert_into_ao_integrals_map(n_integrals_1,buffer_i_1,buffer_values_1)
+        endif
+        if (n_integrals_2 > 0) then
+          call insert_into_ao_integrals_map_2(n_integrals_2,buffer_i_2,buffer_values_2)
+        endif
+      enddo !kk
+  !$OMP END DO NOWAIT
+  deallocate( &
+    ints_ik, &
+    ints_ikjl, &
+    buffer_i_1, &
+    buffer_i_2, &
+    buffer_values_1, &
+    buffer_values_2 &
+    )
+  !$OMP END PARALLEL
+    enddo !kj
+    call wall_time(wall_2)
+    if (wall_2 - wall_0 > 1.d0) then
+      wall_0 = wall_2
+      print*, 100.*float(kl)/float(kpt_num), '% in ',               &
+          wall_2-wall_1,'s',map_mb(ao_integrals_map),'+',map_mb(ao_integrals_map_2),'MB'
+    endif
+
+  enddo !kl
+  deallocate( ints_jl ) 
+
+  call map_sort(ao_integrals_map)
+  call map_unique(ao_integrals_map)
+  call map_sort(ao_integrals_map_2)
+  call map_unique(ao_integrals_map_2)
+  !call map_save_to_disk(trim(ezfio_filename)//'/work/ao_ints_complex_1',ao_integrals_map)
+  !call map_save_to_disk(trim(ezfio_filename)//'/work/ao_ints_complex_2',ao_integrals_map_2)
+  !call ezfio_set_ao_two_e_ints_io_ao_two_e_integrals('Read')
+  
+  call wall_time(wall_2)
+  call cpu_time(cpu_2)
+
+  integer*8                      :: get_ao_map_size, ao_map_size
+  ao_map_size = get_ao_map_size()
+  
+  print*,'AO integrals provided:'
+  print*,' Size of AO map           ', map_mb(ao_integrals_map),'+',map_mb(ao_integrals_map_2),'MB'
+  print*,' Number of AO integrals: ',  ao_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 subroutine ao_map_fill_from_df
+

src/ao_two_e_ints/map_integrals.irp.f

@@ -4,6 +4,7 @@ use map_module
 !! ======
 
 BEGIN_PROVIDER [ type(map_type), ao_integrals_map ]
+&BEGIN_PROVIDER [ type(map_type), ao_integrals_map_2 ]
   implicit none
   BEGIN_DOC
   ! AO integrals
@@ -11,9 +12,17 @@ BEGIN_PROVIDER [ type(map_type), ao_integrals_map ]
   integer(key_kind)              :: key_max
   integer(map_size_kind)         :: sze
   call two_e_integrals_index(ao_num,ao_num,ao_num,ao_num,key_max)
-  sze = key_max
-  call map_init(ao_integrals_map,sze)
-  print*,  'AO map initialized : ', sze
+  if (is_complex) then
+    sze = key_max*2
+    call map_init(ao_integrals_map,sze)
+    call map_init(ao_integrals_map_2,sze) 
+    print*,  'AO maps initialized (complex): ', 2*sze
+  else
+    sze = key_max
+    call map_init(ao_integrals_map,sze)
+    call map_init(ao_integrals_map_2,1_map_size_kind) 
+    print*,  'AO map initialized : ', sze
+  endif
 END_PROVIDER
 
 subroutine two_e_integrals_index(i,j,k,l,i1)
@@ -21,7 +30,7 @@ subroutine two_e_integrals_index(i,j,k,l,i1)
   implicit none
   BEGIN_DOC
 ! Gives a unique index for i,j,k,l using permtuation symmetry.
-! i <-> k, j <-> l, and (i,k) <-> (j,l)
+! i <-> k, j <-> l, and (i,k) <-> (j,l) 
   END_DOC
   integer, intent(in)            :: i,j,k,l
   integer(key_kind), intent(out) :: i1
@@ -144,28 +153,30 @@ BEGIN_PROVIDER [ double precision, ao_integrals_cache, (0:64*64*64*64) ]
  END_DOC
  PROVIDE ao_two_e_integrals_in_map
  integer                        :: i,j,k,l,ii
- integer(key_kind)              :: idx
+ integer(key_kind)              :: idx, idx2
  real(integral_kind)            :: integral
- !$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral)
- do l=ao_integrals_cache_min,ao_integrals_cache_max
-   do k=ao_integrals_cache_min,ao_integrals_cache_max
-     do j=ao_integrals_cache_min,ao_integrals_cache_max
-       do i=ao_integrals_cache_min,ao_integrals_cache_max
-         !DIR$ FORCEINLINE
-         call two_e_integrals_index(i,j,k,l,idx)
-         !DIR$ FORCEINLINE
-         call map_get(ao_integrals_map,idx,integral)
-         ii = l-ao_integrals_cache_min
-         ii = ior( shiftl(ii,6), k-ao_integrals_cache_min)
-         ii = ior( shiftl(ii,6), j-ao_integrals_cache_min)
-         ii = ior( shiftl(ii,6), i-ao_integrals_cache_min)
-         ao_integrals_cache(ii) = integral
-       enddo
-     enddo
-   enddo
- enddo
- !$OMP END PARALLEL DO
+ real(integral_kind)            :: tmp_re, tmp_im
+ integer(key_kind)              :: idx_re,idx_im
 
+  !$OMP PARALLEL DO PRIVATE (i,j,k,l,idx,ii,integral)
+  do l=ao_integrals_cache_min,ao_integrals_cache_max
+    do k=ao_integrals_cache_min,ao_integrals_cache_max
+      do j=ao_integrals_cache_min,ao_integrals_cache_max
+        do i=ao_integrals_cache_min,ao_integrals_cache_max
+          !DIR$ FORCEINLINE
+          call two_e_integrals_index(i,j,k,l,idx)
+          !DIR$ FORCEINLINE
+          call map_get(ao_integrals_map,idx,integral)
+          ii = l-ao_integrals_cache_min
+          ii = ior( shiftl(ii,6), k-ao_integrals_cache_min)
+          ii = ior( shiftl(ii,6), j-ao_integrals_cache_min)
+          ii = ior( shiftl(ii,6), i-ao_integrals_cache_min)
+          ao_integrals_cache(ii) = integral
+        enddo
+      enddo
+    enddo
+  enddo
+  !$OMP END PARALLEL DO
 END_PROVIDER
 
 
@@ -207,7 +218,6 @@ double precision function get_ao_two_e_integral(i,j,k,l,map) result(result)
   result = tmp
 end
 
-
 subroutine get_ao_two_e_integrals(j,k,l,sze,out_val)
   use map_module
   BEGIN_DOC
@@ -237,6 +247,8 @@ subroutine get_ao_two_e_integrals(j,k,l,sze,out_val)
 
 end
 
+
+
 subroutine get_ao_two_e_integrals_non_zero(j,k,l,sze,out_val,out_val_index,non_zero_int)
   use map_module
   implicit none
@@ -251,6 +263,10 @@ subroutine get_ao_two_e_integrals_non_zero(j,k,l,sze,out_val,out_val_index,non_z
   integer                        :: i
   integer(key_kind)              :: hash
   double precision               :: thresh,tmp
+  if(is_complex) then
+    print*,'not implemented for periodic:',irp_here
+    stop -1
+  endif
   PROVIDE ao_two_e_integrals_in_map
   thresh = ao_integrals_threshold
 
@@ -295,6 +311,10 @@ subroutine get_ao_two_e_integrals_non_zero_jl(j,l,thresh,sze_max,sze,out_val,out
   integer(key_kind)              :: hash
   double precision               :: tmp
 
+  if(is_complex) then
+    print*,'not implemented for periodic:',irp_here
+    stop -1
+  endif
   PROVIDE ao_two_e_integrals_in_map
   non_zero_int = 0
   if (ao_overlap_abs(j,l) < thresh) then
@@ -341,6 +361,10 @@ subroutine get_ao_two_e_integrals_non_zero_jl_from_list(j,l,thresh,list,n_list,s
   integer(key_kind)              :: hash
   double precision               :: tmp
 
+  if(is_complex) then
+    print*,'not implemented for periodic:',irp_here
+    stop -1
+  endif
   PROVIDE ao_two_e_integrals_in_map
   non_zero_int = 0
   if (ao_overlap_abs(j,l) < thresh) then
@@ -379,7 +403,7 @@ function get_ao_map_size()
   BEGIN_DOC
   ! Returns the number of elements in the AO map
   END_DOC
-  get_ao_map_size = ao_integrals_map % n_elements
+  get_ao_map_size = ao_integrals_map % n_elements + ao_integrals_map_2 % n_elements
 end
 
 subroutine clear_ao_map
@@ -389,6 +413,9 @@ subroutine clear_ao_map
   END_DOC
   call map_deinit(ao_integrals_map)
   FREE ao_integrals_map
+  call map_deinit(ao_integrals_map_2)
+  FREE ao_integrals_map_2
+  
 end
 
 
@@ -407,81 +434,3 @@ subroutine insert_into_ao_integrals_map(n_integrals,buffer_i, buffer_values)
 end
 
 
-subroutine dump_ao_integrals(filename)
-  use map_module
-  implicit none
-  BEGIN_DOC
-  ! Save to disk the |AO| integrals
-  END_DOC
-  character*(*), intent(in)      :: filename
-  integer(cache_key_kind), pointer :: key(:)
-  real(integral_kind), pointer   :: val(:)
-  integer*8                      :: i,j, n
-  if (.not.mpi_master) then
-    return
-  endif
-  call ezfio_set_work_empty(.False.)
-  open(unit=66,file=filename,FORM='unformatted')
-  write(66) integral_kind, key_kind
-  write(66) ao_integrals_map%sorted, ao_integrals_map%map_size,    &
-      ao_integrals_map%n_elements
-  do i=0_8,ao_integrals_map%map_size
-    write(66) ao_integrals_map%map(i)%sorted, ao_integrals_map%map(i)%map_size,&
-        ao_integrals_map%map(i)%n_elements
-  enddo
-  do i=0_8,ao_integrals_map%map_size
-    key => ao_integrals_map%map(i)%key
-    val => ao_integrals_map%map(i)%value
-    n = ao_integrals_map%map(i)%n_elements
-    write(66) (key(j), j=1,n), (val(j), j=1,n)
-  enddo
-  close(66)
-
-end
-
-
-integer function load_ao_integrals(filename)
-  implicit none
-  BEGIN_DOC
-  ! Read from disk the |AO| integrals
-  END_DOC
-  character*(*), intent(in)      :: filename
-  integer*8                      :: i
-  integer(cache_key_kind), pointer :: key(:)
-  real(integral_kind), pointer   :: val(:)
-  integer                        :: iknd, kknd
-  integer*8                      :: n, j
-  load_ao_integrals = 1
-  open(unit=66,file=filename,FORM='unformatted',STATUS='UNKNOWN')
-  read(66,err=98,end=98) iknd, kknd
-  if (iknd /= integral_kind) then
-    print *,  'Wrong integrals kind in file :', iknd
-    stop 1
-  endif
-  if (kknd /= key_kind) then
-    print *,  'Wrong key kind in file :', kknd
-    stop 1
-  endif
-  read(66,err=98,end=98) ao_integrals_map%sorted, ao_integrals_map%map_size,&
-      ao_integrals_map%n_elements
-  do i=0_8, ao_integrals_map%map_size
-    read(66,err=99,end=99) ao_integrals_map%map(i)%sorted,          &
-        ao_integrals_map%map(i)%map_size, ao_integrals_map%map(i)%n_elements
-    call cache_map_reallocate(ao_integrals_map%map(i),ao_integrals_map%map(i)%map_size)
-  enddo
-  do i=0_8, ao_integrals_map%map_size
-    key => ao_integrals_map%map(i)%key
-    val => ao_integrals_map%map(i)%value
-    n = ao_integrals_map%map(i)%n_elements
-    read(66,err=99,end=99) (key(j), j=1,n), (val(j), j=1,n)
-  enddo
-  call map_sort(ao_integrals_map)
-  load_ao_integrals = 0
-  return
-  99 continue
-  call map_deinit(ao_integrals_map)
-  98 continue
-  stop 'Problem reading ao_integrals_map file in work/'
-
-end
-

src/ao_two_e_ints/map_integrals_cplx.irp.f

@@ -0,0 +1,564 @@
+use map_module
+
+
+subroutine idx2_tri_int(i,j,ij)
+  implicit none
+  integer, intent(in)  :: i,j
+  integer, intent(out) :: ij
+  integer :: p,q
+  p = max(i,j)
+  q = min(i,j)
+  ij = q+ishft(p*p-p,-1)
+end
+
+subroutine idx2_tri_key(i,j,ij)
+  use map_module
+  implicit none
+  integer, intent(in)  :: i,j
+  integer(key_kind), intent(out) :: ij
+  integer(key_kind) :: p,q
+  p = max(i,j)
+  q = min(i,j)
+  ij = q+ishft(p*p-p,-1)
+end
+subroutine two_e_integrals_index_complex(i,j,k,l,i1,p,q)
+  use map_module
+  implicit none
+  BEGIN_DOC
+! Gives a unique index for i,j,k,l using permtuation symmetry.
+! i <-> k, j <-> l, and (i,k) <-> (j,l) 
+  END_DOC
+  integer, intent(in)            :: i,j,k,l
+  integer(key_kind), intent(out) :: i1
+  integer(key_kind)              :: r,s,i2
+  integer(key_kind),intent(out)   :: p,q
+  p = min(i,k)
+  r = max(i,k)
+  p = p+shiftr(r*r-r,1)
+  q = min(j,l)
+  s = max(j,l)
+  q = q+shiftr(s*s-s,1)
+  i1 = min(p,q)
+  i2 = max(p,q)
+  i1 = i1+shiftr(i2*i2-i2,1)
+end
+
+
+
+subroutine two_e_integrals_index_reverse_complex_1(i,j,k,l,i1)
+  use map_module
+  implicit none
+  BEGIN_DOC
+! Computes the 4 indices $i,j,k,l$ from a unique index $i_1$.
+! For 2 indices $i,j$ and $i \le j$, we have
+! $p = i(i-1)/2 + j$.
+! The key point is that because $j < i$,
+! $i(i-1)/2 < p \le i(i+1)/2$. So $i$ can be found by solving
+! $i^2 - i - 2p=0$. One obtains $i=1 + \sqrt{1+8p}/2$
+! and $j = p - i(i-1)/2$.
+! This rule is applied 3 times. First for the symmetry of the
+! pairs (i,k) and (j,l), and then for the symmetry within each pair.
+! always returns first set such that i<=k, j<=l, ik<=jl
+  END_DOC
+  integer, intent(out)           :: i(4),j(4),k(4),l(4)
+  integer(key_kind), intent(in)  :: i1
+  integer(key_kind)              :: i2,i3
+  i = 0
+  i2   = ceiling(0.5d0*(dsqrt(dble(shiftl(i1,3)+1))-1.d0))
+  l(1) = ceiling(0.5d0*(dsqrt(dble(shiftl(i2,3)+1))-1.d0))
+  i3   = i1 - shiftr(i2*i2-i2,1)
+  k(1) = ceiling(0.5d0*(dsqrt(dble(shiftl(i3,3)+1))-1.d0))
+  j(1) = int(i2 - shiftr(l(1)*l(1)-l(1),1),4)
+  i(1) = int(i3 - shiftr(k(1)*k(1)-k(1),1),4)
+
+              !ijkl a+ib
+  i(2) = j(1) !jilk a+ib
+  j(2) = i(1)
+  k(2) = l(1)
+  l(2) = k(1)
+
+  i(3) = k(1) !klij a-ib
+  j(3) = l(1)
+  k(3) = i(1)
+  l(3) = j(1)
+
+  i(4) = l(1) !lkji a-ib
+  j(4) = k(1)
+  k(4) = j(1)
+  l(4) = i(1)
+
+  integer :: ii, jj
+  do ii=2,4
+    do jj=1,ii-1
+      if ( (i(ii) == i(jj)).and. &
+           (j(ii) == j(jj)).and. &
+           (k(ii) == k(jj)).and. &
+           (l(ii) == l(jj)) ) then
+         i(ii) = 0
+         exit
+      endif
+    enddo
+  enddo
+end
+
+subroutine two_e_integrals_index_reverse_complex_2(i,j,k,l,i1)
+  use map_module
+  implicit none
+  BEGIN_DOC
+! Computes the 4 indices $i,j,k,l$ from a unique index $i_1$.
+! For 2 indices $i,j$ and $i \le j$, we have
+! $p = i(i-1)/2 + j$.
+! The key point is that because $j < i$,
+! $i(i-1)/2 < p \le i(i+1)/2$. So $i$ can be found by solving
+! $i^2 - i - 2p=0$. One obtains $i=1 + \sqrt{1+8p}/2$
+! and $j = p - i(i-1)/2$.
+! This rule is applied 3 times. First for the symmetry of the
+! pairs (i,k) and (j,l), and then for the symmetry within each pair.
+! always returns first set such that k<=i, j<=l, ik<=jl
+  END_DOC
+  integer, intent(out)           :: i(4),j(4),k(4),l(4)
+  integer(key_kind), intent(in)  :: i1
+  integer(key_kind)              :: i2,i3
+  i = 0
+  i2   = ceiling(0.5d0*(dsqrt(dble(shiftl(i1,3)+1))-1.d0))
+  l(1) = ceiling(0.5d0*(dsqrt(dble(shiftl(i2,3)+1))-1.d0))
+  i3   = i1 - shiftr(i2*i2-i2,1)
+  i(1) = ceiling(0.5d0*(dsqrt(dble(shiftl(i3,3)+1))-1.d0))
+  j(1) = int(i2 - shiftr(l(1)*l(1)-l(1),1),4)
+  k(1) = int(i3 - shiftr(i(1)*i(1)-i(1),1),4)
+
+              !kjil a+ib
+  i(2) = j(1) !jkli a+ib
+  j(2) = i(1)
+  k(2) = l(1)
+  l(2) = k(1)
+
+  i(3) = k(1) !ilkj a-ib
+  j(3) = l(1)
+  k(3) = i(1)
+  l(3) = j(1)
+
+  i(4) = l(1) !lijk a-ib
+  j(4) = k(1)
+  k(4) = j(1)
+  l(4) = i(1)
+
+  integer :: ii, jj
+  do ii=2,4
+    do jj=1,ii-1
+      if ( (i(ii) == i(jj)).and. &
+           (j(ii) == j(jj)).and. &
+           (k(ii) == k(jj)).and. &
+           (l(ii) == l(jj)) ) then
+         i(ii) = 0
+         exit
+      endif
+    enddo
+  enddo
+end
+
+
+BEGIN_PROVIDER [ complex*16, ao_integrals_cache_complex, (0:64*64*64*64) ]
+ implicit none
+ BEGIN_DOC
+ ! Cache of AO integrals for fast access
+ END_DOC
+ PROVIDE ao_two_e_integrals_in_map
+ integer                        :: i,j,k,l,ii
+ integer(key_kind)              :: idx1, idx2
+ real(integral_kind)            :: tmp_re, tmp_im
+ integer(key_kind)              :: idx_re,idx_im
+ complex(integral_kind)         :: integral
+  integer(key_kind)              :: p,q,r,s,ik,jl
+  logical :: ilek, jlel, iklejl
+  complex*16 :: get_ao_two_e_integral_complex_simple
+
+
+ !$OMP PARALLEL DO PRIVATE (ilek,jlel,p,q,r,s, ik,jl,iklejl, &
+ !$OMP                     i,j,k,l,idx1,idx2,tmp_re,tmp_im,idx_re,idx_im,ii,integral)
+ do l=ao_integrals_cache_min,ao_integrals_cache_max
+   do k=ao_integrals_cache_min,ao_integrals_cache_max
+     do j=ao_integrals_cache_min,ao_integrals_cache_max
+       do i=ao_integrals_cache_min,ao_integrals_cache_max
+         !DIR$ FORCEINLINE
+         integral = get_ao_two_e_integral_complex_simple(i,j,k,l,&
+                    ao_integrals_map,ao_integrals_map_2)
+         
+         ii = l-ao_integrals_cache_min
+         ii = ior( shiftl(ii,6), k-ao_integrals_cache_min)
+         ii = ior( shiftl(ii,6), j-ao_integrals_cache_min)
+         ii = ior( shiftl(ii,6), i-ao_integrals_cache_min)
+         ao_integrals_cache_complex(ii) = integral
+       enddo
+     enddo
+   enddo
+ enddo
+ !$OMP END PARALLEL DO
+
+END_PROVIDER
+
+subroutine ao_two_e_integral_complex_map_idx_sign(i,j,k,l,use_map1,idx,sign) 
+  use map_module
+  implicit none
+  BEGIN_DOC
+  ! get position of periodic AO integral <ij|kl> 
+  ! use_map1: true if integral is in first ao map, false if integral is in second ao map
+  ! idx: position of real part of integral in map (imag part is at idx+1)
+  ! sign: sign of imaginary part
+  !
+  !
+  !  for <ab|cd>, conditionals are [a<c, b<d, ac<bd]
+  !  last two rows are real (ab==cd)
+  ! +---------+---------+---------+---------+---------+---------+---------+---------+---------+
+  ! | NEW     | <ij|kl> | <ji|lk> | <kl|ij> | <lk|ji> | <kj|il> | <jk|li> | <il|kj> | <li|jk> |
+  ! +---------+---------+---------+---------+---------+---------+---------+---------+---------+
+  ! |         |         m1        |         m1*       |         m2        |         m2*       |
+  ! +---------+---------+---------+---------+---------+---------+---------+---------+---------+
+  ! | <ij|kl> | TTT     | TTF     | FFT     | FFF     | FTT     | TFF     | TFT     | FTF     |
+  ! | <ij|il> | 0TT     | T0F     | 0FT     | F0F     |         |         |         |         |
+  ! | <ij|kj> | T0T     | 0TF     | F0T     | 0FF     |         |         |         |         |
+  ! | <ii|jj> | TT0     |         | FF0     |         | FT0(r)  | TF0(r)  |         |         |
+  ! +---------+---------+---------+---------+---------+---------+---------+---------+---------+
+  ! | <ij|ij> |         |         |         |         | 00T(r)  | 00F(r)  |         |         |
+  ! | <ii|ii> |         |         |         |         | 000     |         |         |         |
+  ! +---------+---------+---------+---------+---------+---------+---------+---------+---------+
+  END_DOC
+  integer, intent(in)            :: i,j,k,l
+  integer(key_kind), intent(out) :: idx
+  logical, intent(out)           :: use_map1
+  double precision, intent(out)  :: sign
+  integer(key_kind)              :: p,q,r,s,ik,jl,ij,kl
+  !DIR$ FORCEINLINE
+  call two_e_integrals_index_complex(i,j,k,l,idx,ik,jl)
+  p = min(i,j)
+  r = max(i,j)
+  ij = p+shiftr(r*r-r,1)
+  q = min(k,l)
+  s = max(k,l)
+  kl = q+shiftr(s*s-s,1)
+
+  idx = 2*idx-1
+
+  if (ij==kl) then !real, J -> map1, K -> map2
+    sign=0.d0
+    use_map1=.False.
+  else
+    if (ik.eq.jl) then
+      if (i.lt.k) then   !TT0
+        sign=1.d0
+        use_map1=.True. 
+      else               !FF0
+        sign=-1.d0
+        use_map1=.True.
+      endif
+    else if (i.eq.k) then
+      if (j.lt.l) then   !0T* 
+        sign=1.d0
+        use_map1=.True.
+      else               !0F*
+        sign=-1.d0
+        use_map1=.True.
+      endif
+    else if (j.eq.l) then
+      if (i.lt.k) then
+        sign=1.d0
+        use_map1=.True.
+      else
+        sign=-1.d0
+        use_map1=.True.
+      endif
+    else if ((i.lt.k).eqv.(j.lt.l)) then
+      if (i.lt.k) then
+        sign=1.d0
+        use_map1=.True.
+      else
+        sign=-1.d0
+        use_map1=.True.
+      endif
+    else
+      if ((j.lt.l).eqv.(ik.lt.jl)) then
+        sign=1.d0
+        use_map1=.False.
+      else
+        sign=-1.d0
+        use_map1=.False.
+      endif
+    endif
+  endif
+end
+
+complex*16 function get_ao_two_e_integral_complex_simple(i,j,k,l,map,map2) result(result)
+  use map_module
+  implicit none
+  BEGIN_DOC
+  ! Gets one AO bi-electronic integral from the AO map
+  END_DOC
+  integer, intent(in)            :: i,j,k,l
+  integer(key_kind)              :: idx1,idx2,idx
+  real(integral_kind)            :: tmp_re, tmp_im
+  integer(key_kind)              :: idx_re,idx_im
+  type(map_type), intent(inout)  :: map,map2
+  integer                        :: ii
+  complex(integral_kind)         :: tmp
+  integer(key_kind)              :: p,q,r,s,ik,jl
+  logical :: ilek, jlel, iklejl,use_map1
+  double precision :: sign
+  ! a.le.c, b.le.d, tri(a,c).le.tri(b,d)
+  PROVIDE ao_two_e_integrals_in_map
+  call ao_two_e_integral_complex_map_idx_sign(i,j,k,l,use_map1,idx,sign)
+  if (use_map1) then
+    call map_get(map,idx,tmp_re)
+    call map_get(map,idx+1,tmp_im)
+    tmp_im *= sign
+  else
+    call map_get(map2,idx,tmp_re)
+    if (sign/=0.d0) then
+      call map_get(map2,idx+1,tmp_im)
+      tmp_im *= sign
+    else
+      tmp_im=0.d0
+    endif
+  endif
+  tmp = dcmplx(tmp_re,tmp_im)
+  result = tmp
+end
+
+
+complex*16 function get_ao_two_e_integral_complex(i,j,k,l,map,map2) result(result)
+  use map_module
+  implicit none
+  BEGIN_DOC
+  ! Gets one AO bi-electronic integral from the AO map
+  END_DOC
+  integer, intent(in)            :: i,j,k,l
+  integer(key_kind)              :: idx1,idx2
+  real(integral_kind)            :: tmp_re, tmp_im
+  integer(key_kind)              :: idx_re,idx_im
+  type(map_type), intent(inout)  :: map,map2
+  integer                        :: ii
+  complex(integral_kind)         :: tmp
+  complex(integral_kind)         :: get_ao_two_e_integral_complex_simple
+  integer(key_kind)              :: p,q,r,s,ik,jl
+  logical :: ilek, jlel, iklejl
+  ! a.le.c, b.le.d, tri(a,c).le.tri(b,d)
+  PROVIDE ao_two_e_integrals_in_map ao_integrals_cache_complex ao_integrals_cache_min
+  !DIR$ FORCEINLINE
+!  if (ao_overlap_abs(i,k)*ao_overlap_abs(j,l) < ao_integrals_threshold ) then
+!    tmp = (0.d0,0.d0)
+!  else if (ao_two_e_integral_schwartz(i,k)*ao_two_e_integral_schwartz(j,l) < ao_integrals_threshold) then
+!    tmp = (0.d0,0.d0)
+!  else
+  if (.True.) then
+    ii = l-ao_integrals_cache_min
+    ii = ior(ii, k-ao_integrals_cache_min)
+    ii = ior(ii, j-ao_integrals_cache_min)
+    ii = ior(ii, i-ao_integrals_cache_min)
+    if (iand(ii, -64) /= 0) then
+      tmp = get_ao_two_e_integral_complex_simple(i,j,k,l,map,map2)
+    else
+      ii = l-ao_integrals_cache_min
+      ii = ior( shiftl(ii,6), k-ao_integrals_cache_min)
+      ii = ior( shiftl(ii,6), j-ao_integrals_cache_min)
+      ii = ior( shiftl(ii,6), i-ao_integrals_cache_min)
+      tmp = ao_integrals_cache_complex(ii)
+    endif
+    result = tmp
+  endif
+end
+
+
+subroutine get_ao_two_e_integrals_complex(j,k,l,sze,out_val)
+  use map_module
+  BEGIN_DOC
+  ! Gets multiple AO bi-electronic integral from the AO map .
+  ! All i are retrieved for j,k,l fixed.
+  ! physicist convention : <ij|kl> 
+  END_DOC
+  implicit none
+  integer, intent(in)            :: j,k,l, sze
+  complex*16, intent(out) :: out_val(sze)
+
+  integer                        :: i
+  integer(key_kind)              :: hash
+  double precision               :: thresh
+  PROVIDE ao_two_e_integrals_in_map ao_integrals_map
+  thresh = ao_integrals_threshold
+
+  if (ao_overlap_abs(j,l) < thresh) then
+    out_val = (0.d0,0.d0)
+    return
+  endif
+
+  complex*16 :: get_ao_two_e_integral_complex
+  do i=1,sze
+    out_val(i) = get_ao_two_e_integral_complex(i,j,k,l,ao_integrals_map,ao_integrals_map_2)
+  enddo
+
+end
+
+subroutine get_ao_two_e_integrals_non_zero_complex(j,k,l,sze,out_val,out_val_index,non_zero_int)
+  print*,'not implemented for periodic',irp_here
+  stop -1
+!  use map_module
+!  implicit none
+!  BEGIN_DOC
+!  ! Gets multiple AO bi-electronic integral from the AO map .
+!  ! All non-zero i are retrieved for j,k,l fixed.
+!  END_DOC
+!  integer, intent(in)            :: j,k,l, sze
+!  real(integral_kind), intent(out) :: out_val(sze)
+!  integer, intent(out)           :: out_val_index(sze),non_zero_int
+!
+!  integer                        :: i
+!  integer(key_kind)              :: hash
+!  double precision               :: thresh,tmp
+!  if(is_complex) then
+!    print*,'not implemented for periodic:',irp_here
+!    stop -1
+!  endif
+!  PROVIDE ao_two_e_integrals_in_map
+!  thresh = ao_integrals_threshold
+!
+!  non_zero_int = 0
+!  if (ao_overlap_abs(j,l) < thresh) then
+!    out_val = 0.d0
+!    return
+!  endif
+!
+!  non_zero_int = 0
+!  do i=1,sze
+!    integer, external :: ao_l4
+!    double precision, external :: ao_two_e_integral
+!    !DIR$ FORCEINLINE
+!    if (ao_two_e_integral_schwartz(i,k)*ao_two_e_integral_schwartz(j,l) < thresh) then
+!      cycle
+!    endif
+!    call two_e_integrals_index(i,j,k,l,hash)
+!    call map_get(ao_integrals_map, hash,tmp)
+!    if (dabs(tmp) < thresh ) cycle
+!    non_zero_int = non_zero_int+1
+!    out_val_index(non_zero_int) = i
+!    out_val(non_zero_int) = tmp
+!  enddo
+
+end
+
+
+subroutine get_ao_two_e_integrals_non_zero_jl_complex(j,l,thresh,sze_max,sze,out_val,out_val_index,non_zero_int)
+  print*,'not implemented for periodic',irp_here
+  stop -1
+!  use map_module
+!  implicit none
+!  BEGIN_DOC
+!  ! Gets multiple AO bi-electronic integral from the AO map .
+!  ! All non-zero i are retrieved for j,k,l fixed.
+!  END_DOC
+!  double precision, intent(in)   :: thresh
+!  integer, intent(in)            :: j,l, sze,sze_max
+!  real(integral_kind), intent(out) :: out_val(sze_max)
+!  integer, intent(out)           :: out_val_index(2,sze_max),non_zero_int
+!
+!  integer                        :: i,k
+!  integer(key_kind)              :: hash
+!  double precision               :: tmp
+!
+!  if(is_complex) then
+!    print*,'not implemented for periodic:',irp_here
+!    stop -1
+!  endif
+!  PROVIDE ao_two_e_integrals_in_map
+!  non_zero_int = 0
+!  if (ao_overlap_abs(j,l) < thresh) then
+!    out_val = 0.d0
+!    return
+!  endif
+!
+!  non_zero_int = 0
+!  do k = 1, sze
+!   do i = 1, sze
+!     integer, external :: ao_l4
+!     double precision, external :: ao_two_e_integral
+!     !DIR$ FORCEINLINE
+!     if (ao_two_e_integral_schwartz(i,k)*ao_two_e_integral_schwartz(j,l) < thresh) then
+!       cycle
+!     endif
+!     call two_e_integrals_index(i,j,k,l,hash)
+!     call map_get(ao_integrals_map, hash,tmp)
+!     if (dabs(tmp) < thresh ) cycle
+!     non_zero_int = non_zero_int+1
+!     out_val_index(1,non_zero_int) = i
+!     out_val_index(2,non_zero_int) = k
+!     out_val(non_zero_int) = tmp
+!   enddo
+!  enddo
+
+end
+
+
+subroutine get_ao_two_e_integrals_non_zero_jl_from_list_complex(j,l,thresh,list,n_list,sze_max,out_val,out_val_index,non_zero_int)
+  print*,'not implemented for periodic',irp_here
+  stop -1
+!  use map_module
+!  implicit none
+!  BEGIN_DOC
+!  ! Gets multiple AO two-electron integrals from the AO map .
+!  ! All non-zero i are retrieved for j,k,l fixed.
+!  END_DOC
+!  double precision, intent(in)   :: thresh
+!  integer, intent(in)            :: sze_max
+!  integer, intent(in)            :: j,l, n_list,list(2,sze_max)
+!  real(integral_kind), intent(out) :: out_val(sze_max)
+!  integer, intent(out)           :: out_val_index(2,sze_max),non_zero_int
+!
+!  integer                        :: i,k
+!  integer(key_kind)              :: hash
+!  double precision               :: tmp
+!
+!  if(is_complex) then
+!    print*,'not implemented for periodic:',irp_here
+!    stop -1
+!  endif
+!  PROVIDE ao_two_e_integrals_in_map
+!  non_zero_int = 0
+!  if (ao_overlap_abs(j,l) < thresh) then
+!    out_val = 0.d0
+!    return
+!  endif
+!
+!  non_zero_int = 0
+! integer :: kk
+!  do kk = 1, n_list
+!   k = list(1,kk)
+!   i = list(2,kk)
+!   integer, external :: ao_l4
+!   double precision, external :: ao_two_e_integral
+!   !DIR$ FORCEINLINE
+!   if (ao_two_e_integral_schwartz(i,k)*ao_two_e_integral_schwartz(j,l) < thresh) then
+!     cycle
+!   endif
+!   call two_e_integrals_index(i,j,k,l,hash)
+!   call map_get(ao_integrals_map, hash,tmp)
+!   if (dabs(tmp) < thresh ) cycle
+!   non_zero_int = non_zero_int+1
+!   out_val_index(1,non_zero_int) = i
+!   out_val_index(2,non_zero_int) = k
+!   out_val(non_zero_int) = tmp
+!  enddo
+
+end
+
+subroutine insert_into_ao_integrals_map_2(n_integrals,buffer_i, buffer_values)
+  use map_module
+  implicit none
+  BEGIN_DOC
+  ! Create new entry into AO map
+  END_DOC
+
+  integer, intent(in)                :: n_integrals
+  integer(key_kind), intent(inout)   :: buffer_i(n_integrals)
+  real(integral_kind), intent(inout) :: buffer_values(n_integrals)
+
+  call map_append(ao_integrals_map_2, buffer_i, buffer_values, n_integrals)
+end
+
+

src/ao_two_e_ints/two_e_integrals.irp.f

@@ -348,77 +348,96 @@ BEGIN_PROVIDER [ logical, ao_two_e_integrals_in_map ]
   integer                        :: kk, m, j1, i1, lmax
   character*(64)                 :: fmt
 
-  integral = ao_two_e_integral(1,1,1,1)
 
   double precision               :: map_mb
   PROVIDE read_ao_two_e_integrals io_ao_two_e_integrals
-  if (read_ao_two_e_integrals) then
-    print*,'Reading the AO integrals'
+  if (is_complex) then
+    if (read_ao_two_e_integrals) then
+      print*,'Reading the AO integrals (periodic)'
+      call map_load_from_disk(trim(ezfio_filename)//'/work/ao_ints_complex_1',ao_integrals_map)
+      call map_load_from_disk(trim(ezfio_filename)//'/work/ao_ints_complex_2',ao_integrals_map_2)
+      print*, 'AO integrals provided (periodic)'
+      ao_two_e_integrals_in_map = .True.
+      return
+    else if (read_df_ao_integrals) then
+      call ao_map_fill_from_df
+      print*, 'AO integrals provided from 3-index ao ints (periodic)'
+      ao_two_e_integrals_in_map = .True.
+      return
+    else
+      print*,'calculation of periodic AOs not implemented'
+      stop -1
+    endif
+
+  else
+    if (read_ao_two_e_integrals) then
+      print*,'Reading the AO integrals'
       call map_load_from_disk(trim(ezfio_filename)//'/work/ao_ints',ao_integrals_map)
       print*, 'AO integrals provided'
       ao_two_e_integrals_in_map = .True.
       return
-  endif
-
-  print*, 'Providing the AO integrals'
-  call wall_time(wall_0)
-  call wall_time(wall_1)
-  call cpu_time(cpu_1)
-
-  integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
-  call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'ao_integrals')
-
-  character(len=:), allocatable :: task
-  allocate(character(len=ao_num*12) :: task)
-  write(fmt,*) '(', ao_num, '(I5,X,I5,''|''))'
-  do l=1,ao_num
-    write(task,fmt) (i,l, i=1,l)
-    integer, external :: add_task_to_taskserver
-    if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) == -1) then
-      stop 'Unable to add task to server'
     endif
-  enddo
-  deallocate(task)
-
-  integer, external :: zmq_set_running
-  if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
-    print *,  irp_here, ': Failed in zmq_set_running'
-  endif
-
-  PROVIDE nproc
-  !$OMP PARALLEL DEFAULT(shared) private(i) num_threads(nproc+1)
-      i = omp_get_thread_num()
-      if (i==0) then
-        call ao_two_e_integrals_in_map_collector(zmq_socket_pull)
-      else
-        call ao_two_e_integrals_in_map_slave_inproc(i)
+  
+    integral = ao_two_e_integral(1,1,1,1)
+    print*, 'Providing the AO integrals'
+    call wall_time(wall_0)
+    call wall_time(wall_1)
+    call cpu_time(cpu_1)
+  
+    integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
+    call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'ao_integrals')
+  
+    character(len=:), allocatable :: task
+    allocate(character(len=ao_num*12) :: task)
+    write(fmt,*) '(', ao_num, '(I5,X,I5,''|''))'
+    do l=1,ao_num
+      write(task,fmt) (i,l, i=1,l)
+      integer, external :: add_task_to_taskserver
+      if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task)) == -1) then
+        stop 'Unable to add task to server'
       endif
-  !$OMP END PARALLEL
-
-  call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'ao_integrals')
-
-
-  print*, 'Sorting the map'
-  call map_sort(ao_integrals_map)
-  call cpu_time(cpu_2)
-  call wall_time(wall_2)
-  integer(map_size_kind)         :: get_ao_map_size, ao_map_size
-  ao_map_size = get_ao_map_size()
-
-  print*, 'AO integrals provided:'
-  print*, ' Size of AO map :         ', map_mb(ao_integrals_map) ,'MB'
-  print*, ' Number of AO integrals :', ao_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+tiny(1.d0)), ' )'
-
-  ao_two_e_integrals_in_map = .True.
-
-  if (write_ao_two_e_integrals.and.mpi_master) then
-    call ezfio_set_work_empty(.False.)
-    call map_save_to_disk(trim(ezfio_filename)//'/work/ao_ints',ao_integrals_map)
-    call ezfio_set_ao_two_e_ints_io_ao_two_e_integrals('Read')
+    enddo
+    deallocate(task)
+  
+    integer, external :: zmq_set_running
+    if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
+      print *,  irp_here, ': Failed in zmq_set_running'
+    endif
+  
+    PROVIDE nproc
+    !$OMP PARALLEL DEFAULT(shared) private(i) num_threads(nproc+1)
+        i = omp_get_thread_num()
+        if (i==0) then
+          call ao_two_e_integrals_in_map_collector(zmq_socket_pull)
+        else
+          call ao_two_e_integrals_in_map_slave_inproc(i)
+        endif
+    !$OMP END PARALLEL
+  
+    call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'ao_integrals')
+  
+  
+    print*, 'Sorting the map'
+    call map_sort(ao_integrals_map)
+    call cpu_time(cpu_2)
+    call wall_time(wall_2)
+    integer(map_size_kind)         :: get_ao_map_size, ao_map_size
+    ao_map_size = get_ao_map_size()
+  
+    print*, 'AO integrals provided:'
+    print*, ' Size of AO map :         ', map_mb(ao_integrals_map) ,'MB'
+    print*, ' Number of AO integrals :', ao_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+tiny(1.d0)), ' )'
+  
+    ao_two_e_integrals_in_map = .True.
+  
+    if (write_ao_two_e_integrals.and.mpi_master) then
+      call ezfio_set_work_empty(.False.)
+      call map_save_to_disk(trim(ezfio_filename)//'/work/ao_ints',ao_integrals_map)
+      call ezfio_set_ao_two_e_ints_io_ao_two_e_integrals('Read')
+    endif
   endif
-
 END_PROVIDER
 
 BEGIN_PROVIDER [ double precision, ao_two_e_integral_schwartz,(ao_num,ao_num)  ]

src/bitmask/bitmasks.irp.f

@@ -80,9 +80,23 @@ BEGIN_PROVIDER [ integer(bit_kind), HF_bitmask, (N_int,2)]
   integer                        :: occ(elec_alpha_num)
   
   HF_bitmask = 0_bit_kind
-  do i=1,elec_alpha_num
-    occ(i) = i
-  enddo
+  if (is_complex) then
+    integer :: kpt,korb
+    kpt=1
+    korb=1
+    do i=1,elec_alpha_num
+      occ(i) = korb + (kpt-1) * mo_num_per_kpt
+      kpt += 1
+      if (kpt > kpt_num) then
+        kpt = 1
+        korb += 1
+      endif
+    enddo
+  else
+    do i=1,elec_alpha_num
+      occ(i) = i
+    enddo
+  endif
   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)
@@ -240,3 +254,252 @@ BEGIN_PROVIDER [integer(bit_kind), closed_shell_ref_bitmask, (N_int,2)]
     closed_shell_ref_bitmask(i,2) = ior(ref_bitmask(i,2),act_bitmask(i,2))
   enddo
 END_PROVIDER
+ 
+!============================================!
+!                                            !
+!                    kpts                    !
+!                                            !
+!============================================!
+
+!BEGIN_PROVIDER [ integer(bit_kind), full_ijkl_bitmask, (N_int) ]
+!  implicit none
+!  BEGIN_DOC
+!  ! Bitmask to include all possible MOs
+!  END_DOC
+!  
+!  integer                        :: i,j,k
+!  k=0
+!  do j=1,N_int
+!    full_ijkl_bitmask(j) = 0_bit_kind
+!    do i=0,bit_kind_size-1
+!      k=k+1
+!      if (mo_class(k) /= 'Deleted') then
+!        full_ijkl_bitmask(j) = ibset(full_ijkl_bitmask(j),i)
+!      endif
+!      if (k == mo_num) exit
+!    enddo
+!  enddo
+!END_PROVIDER
+!
+!BEGIN_PROVIDER [ integer(bit_kind), full_ijkl_bitmask_4, (N_int,4) ]
+!  implicit none
+!  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)
+!  enddo
+!END_PROVIDER
+!
+!BEGIN_PROVIDER [ integer(bit_kind), core_inact_act_bitmask_4, (N_int,4) ]
+!  implicit none
+!  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)
+!  enddo
+!END_PROVIDER
+!
+!BEGIN_PROVIDER [ integer(bit_kind), virt_bitmask_4, (N_int,4) ]
+!  implicit none
+!  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)
+!  enddo
+!END_PROVIDER
+!
+!
+!
+!
+BEGIN_PROVIDER [ integer(bit_kind), HF_bitmask_kpts, (N_int,2,kpt_num)]
+  implicit none
+  BEGIN_DOC
+  ! Hartree Fock bit mask
+  END_DOC
+  integer                        :: i,k
+  
+  hf_bitmask_kpts = 0_bit_kind
+  do k=1,kpt_num
+    do i=1,N_int
+      hf_bitmask_kpts(i,1,k) = iand(hf_bitmask(i,1),kpts_bitmask(i,k))
+      hf_bitmask_kpts(i,2,k) = iand(hf_bitmask(i,2),kpts_bitmask(i,k))
+    enddo
+  enddo
+END_PROVIDER
+
+BEGIN_PROVIDER [ integer(bit_kind), ref_bitmask_kpts, (N_int,2,kpt_num)]
+  implicit none
+  BEGIN_DOC
+  ! Reference bit mask, used in Slater rules, chosen as Hartree-Fock bitmask
+  END_DOC
+  ref_bitmask_kpts = HF_bitmask_kpts
+END_PROVIDER
+
+
+
+!BEGIN_PROVIDER [ integer(bit_kind), generators_bitmask, (N_int,2,6) ]
+!  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 
+!  
+!  integer                        :: ispin, i
+!  do ispin=1,2
+!      do i=1,N_int
+!        generators_bitmask(i,ispin,s_hole ) = reunion_of_inact_act_bitmask(i,ispin)
+!        generators_bitmask(i,ispin,s_part ) = reunion_of_act_virt_bitmask(i,ispin)
+!        generators_bitmask(i,ispin,d_hole1) = reunion_of_inact_act_bitmask(i,ispin)
+!        generators_bitmask(i,ispin,d_part1) = reunion_of_act_virt_bitmask(i,ispin)
+!        generators_bitmask(i,ispin,d_hole2) = reunion_of_inact_act_bitmask(i,ispin)
+!        generators_bitmask(i,ispin,d_part2) = reunion_of_act_virt_bitmask(i,ispin)
+!      enddo
+!  enddo
+!  
+!END_PROVIDER
+
+BEGIN_PROVIDER [ integer(bit_kind), reunion_of_core_inact_bitmask_kpts, (N_int,2,kpt_num)]
+  implicit none
+  BEGIN_DOC
+  ! Reunion of the core and inactive and virtual bitmasks
+  END_DOC
+  integer                        :: i,k
+  do k=1,kpt_num
+    do i = 1, N_int
+      reunion_of_core_inact_bitmask_kpts(i,1,k) = ior(core_bitmask_kpts(i,1,k),inact_bitmask_kpts(i,1,k))
+      reunion_of_core_inact_bitmask_kpts(i,2,k) = ior(core_bitmask_kpts(i,2,k),inact_bitmask_kpts(i,2,k))
+    enddo
+  enddo
+END_PROVIDER
+
+
+BEGIN_PROVIDER [integer(bit_kind), reunion_of_inact_act_bitmask_kpts, (N_int,2,kpt_num)]
+  implicit none
+  BEGIN_DOC
+  ! Reunion of the  inactive and active bitmasks
+  END_DOC
+  integer                        :: i,k
+  
+  do k=1,kpt_num
+    do i = 1, N_int
+      reunion_of_inact_act_bitmask_kpts(i,1,k) = ior(inact_bitmask_kpts(i,1,k),act_bitmask_kpts(i,1,k))
+      reunion_of_inact_act_bitmask_kpts(i,2,k) = ior(inact_bitmask_kpts(i,2,k),act_bitmask_kpts(i,2,k))
+    enddo
+  enddo
+END_PROVIDER
+
+BEGIN_PROVIDER [integer(bit_kind), reunion_of_act_virt_bitmask_kpts, (N_int,2,kpt_num)]
+  implicit none
+  BEGIN_DOC
+  ! Reunion of the  inactive and active bitmasks
+  END_DOC
+  integer                        :: i,k
+  
+  do k=1,kpt_num
+    do i = 1, N_int
+      reunion_of_act_virt_bitmask_kpts(i,1,k) = ior(virt_bitmask_kpts(i,1,k),act_bitmask_kpts(i,1,k))
+      reunion_of_act_virt_bitmask_kpts(i,2,k) = ior(virt_bitmask_kpts(i,2,k),act_bitmask_kpts(i,2,k))
+    enddo
+  enddo
+END_PROVIDER
+
+
+BEGIN_PROVIDER [integer(bit_kind), reunion_of_core_inact_act_bitmask_kpts, (N_int,2,kpt_num)]
+  implicit none
+  BEGIN_DOC
+  ! Reunion of the core, inactive and active bitmasks
+  END_DOC
+  integer                        :: i,k
+
+  do k=1,kpt_num
+    do i = 1, N_int
+      reunion_of_core_inact_act_bitmask_kpts(i,1,k) = ior(reunion_of_core_inact_bitmask_kpts(i,1,k),act_bitmask_kpts(i,1,k))
+      reunion_of_core_inact_act_bitmask_kpts(i,2,k) = ior(reunion_of_core_inact_bitmask_kpts(i,2,k),act_bitmask_kpts(i,2,k))
+    enddo
+  enddo
+END_PROVIDER
+
+
+BEGIN_PROVIDER [ integer(bit_kind), reunion_of_bitmask_kpts, (N_int,2,kpt_num)]
+  implicit none
+  BEGIN_DOC
+  ! Reunion of the inactive, active and virtual bitmasks
+  END_DOC
+  integer                        :: i,k
+  do k=1,kpt_num
+    do i = 1, N_int
+      reunion_of_bitmask_kpts(i,1,k) = ior(ior(act_bitmask_kpts(i,1,k),inact_bitmask_kpts(i,1,k)),virt_bitmask_kpts(i,1,k))
+      reunion_of_bitmask_kpts(i,2,k) = ior(ior(act_bitmask_kpts(i,2,k),inact_bitmask_kpts(i,2,k)),virt_bitmask_kpts(i,2,k))
+    enddo
+  enddo
+END_PROVIDER
+
+
+ BEGIN_PROVIDER [ integer(bit_kind), inact_virt_bitmask_kpts, (N_int,2,kpt_num)]
+&BEGIN_PROVIDER [ integer(bit_kind), core_inact_virt_bitmask_kpts, (N_int,2,kpt_num)]
+  implicit none
+  BEGIN_DOC
+  ! Reunion of the inactive and virtual bitmasks
+  END_DOC
+  integer                        :: i,k
+  do k=1,kpt_num
+    do i = 1, N_int
+      inact_virt_bitmask_kpts(i,1,k) = ior(inact_bitmask_kpts(i,1,k),virt_bitmask_kpts(i,1,k))
+      inact_virt_bitmask_kpts(i,2,k) = ior(inact_bitmask_kpts(i,2,k),virt_bitmask_kpts(i,2,k))
+      core_inact_virt_bitmask_kpts(i,1,k) = ior(core_bitmask_kpts(i,1,k),inact_virt_bitmask_kpts(i,1,k))
+      core_inact_virt_bitmask_kpts(i,2,k) = ior(core_bitmask_kpts(i,2,k),inact_virt_bitmask_kpts(i,2,k))
+    enddo
+  enddo
+END_PROVIDER
+
+
+BEGIN_PROVIDER [ integer(bit_kind), unpaired_alpha_electrons_kpts, (N_int,kpt_num)]
+  implicit none
+  BEGIN_DOC
+  ! Bitmask reprenting the unpaired alpha electrons in the HF_bitmask
+  END_DOC
+  integer                        :: i,k
+  unpaired_alpha_electrons_kpts = 0_bit_kind
+  do k = 1, kpt_num
+    do i = 1, N_int
+      unpaired_alpha_electrons_kpts(i,k) = xor(HF_bitmask_kpts(i,1,k),HF_bitmask_kpts(i,2,k))
+    enddo
+  enddo
+END_PROVIDER
+
+BEGIN_PROVIDER [integer(bit_kind), closed_shell_ref_bitmask_kpts, (N_int,2,kpt_num)]
+  implicit none
+  integer                        :: i,k
+
+  closed_shell_ref_bitmask_kpts = 0_bit_kind
+  do k=1,kpt_num
+    do i = 1, N_int
+      closed_shell_ref_bitmask_kpts(i,1,k) = ior(ref_bitmask_kpts(i,1,k),act_bitmask_kpts(i,1,k))
+      closed_shell_ref_bitmask_kpts(i,2,k) = ior(ref_bitmask_kpts(i,2,k),act_bitmask_kpts(i,2,k))
+    enddo
+  enddo
+END_PROVIDER
+ 

src/bitmask/bitmasks_routines.irp.f

@@ -214,6 +214,37 @@ subroutine print_spindet(string,Nint)
 
 end
 
+subroutine debug_single_spindet(string,Nint)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Subroutine to print the content of a determinant in '+-' notation and
+  ! hexadecimal representation.
+  END_DOC
+  integer, intent(in)            :: Nint
+  integer(bit_kind), intent(in)  :: string(Nint)
+  character*(2048)                :: output(1)
+  call bitstring_to_hexa( output(1), string(1), Nint )
+  print *,  trim(output(1))
+  call print_single_spindet(string,Nint)
+
+end
+
+subroutine print_single_spindet(string,Nint)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Subroutine to print the content of a determinant using the '+-' notation
+  END_DOC
+  integer, intent(in)            :: Nint
+  integer(bit_kind), intent(in)  :: string(Nint)
+  character*(2048)                :: output(1)
+
+  call bitstring_to_str( output(1), string(1), Nint )
+  print *,  trim(output(1))
+
+end
+
 logical function is_integer_in_string(bite,string,Nint)
   use bitmasks
  implicit none

src/bitmask/core_inact_act_virt.irp.f

@@ -413,3 +413,514 @@ END_PROVIDER
    print *,  list_inact_act(1:n_inact_act_orb)
 END_PROVIDER
  
+!============================================!
+!                                            !
+!                    kpts                    !
+!                                            !
+!============================================!
+BEGIN_PROVIDER [ integer(bit_kind), kpts_bitmask , (N_int,kpt_num) ]
+  implicit none
+  BEGIN_DOC
+  ! Bitmask identifying each kpt
+  END_DOC
+  integer :: k,i,di
+  integer :: tmp_mo_list(mo_num_per_kpt)
+  kpts_bitmask  = 0_bit_kind
+  print*,'kpts bitmask'
+  do k=1,kpt_num
+    di=(k-1)*mo_num_per_kpt
+    do i=1,mo_num_per_kpt
+      tmp_mo_list(i) = i+di
+    enddo
+    call list_to_bitstring( kpts_bitmask(1,k), tmp_mo_list, mo_num_per_kpt, N_int)
+    !debugging
+    print*,'k = ',k
+    call debug_single_spindet(kpts_bitmask(1,k),N_int)
+  enddo
+END_PROVIDER
+
+BEGIN_PROVIDER [ integer, n_core_orb_kpts, (kpt_num)]
+  implicit none
+  BEGIN_DOC
+  ! Number of core MOs
+  END_DOC
+  integer                        :: i,k,kshift
+
+  do k=1,kpt_num
+    n_core_orb_kpts(k) = 0
+    kshift = (1-k)*mo_num_per_kpt
+    do i = 1, mo_num_per_kpt
+      if(mo_class(i+kshift) == 'Core')then
+        n_core_orb_kpts(k) += 1
+      endif
+    enddo
+  enddo
+  
+!  call write_int(6,n_core_orb, 'Number of core     MOs')
+   
+END_PROVIDER
+
+BEGIN_PROVIDER [ integer, n_inact_orb_kpts, (kpt_num)]
+  implicit none
+  BEGIN_DOC
+  ! Number of inactive MOs
+  END_DOC
+  integer                        :: i,k,kshift
+
+  do k=1,kpt_num
+    n_inact_orb_kpts(k) = 0
+    kshift = (1-k)*mo_num_per_kpt
+    do i = 1, mo_num_per_kpt
+      if(mo_class(i+kshift) == 'Inactive')then
+        n_inact_orb_kpts(k) += 1
+      endif
+    enddo
+  enddo
+  
+!  call write_int(6,n_inact_orb, 'Number of inactive MOs')
+   
+END_PROVIDER
+
+BEGIN_PROVIDER [ integer, n_act_orb_kpts, (kpt_num)]
+  implicit none
+  BEGIN_DOC
+  ! Number of active MOs
+  END_DOC
+  integer                        :: i,k,kshift
+
+  do k=1,kpt_num
+    n_act_orb_kpts(k) = 0
+    kshift = (1-k)*mo_num_per_kpt
+    do i = 1, mo_num_per_kpt
+      if(mo_class(i+kshift) == 'Active')then
+        n_act_orb_kpts(k) += 1
+      endif
+    enddo
+  enddo
+  
+!  call write_int(6,n_act_orb, 'Number of active   MOs')
+   
+END_PROVIDER
+
+BEGIN_PROVIDER [ integer, n_virt_orb_kpts, (kpt_num)]
+  implicit none
+  BEGIN_DOC
+  ! Number of virtual MOs
+  END_DOC
+  integer                        :: i,k,kshift
+
+  do k=1,kpt_num
+    n_virt_orb_kpts(k) = 0
+    kshift = (1-k)*mo_num_per_kpt
+    do i = 1, mo_num_per_kpt
+      if(mo_class(i+kshift) == 'Virtual')then
+        n_virt_orb_kpts(k) += 1
+      endif
+    enddo
+  enddo
+  
+!  call write_int(6,n_virt_orb, 'Number of virtual  MOs')
+   
+END_PROVIDER
+
+BEGIN_PROVIDER [ integer, n_del_orb_kpts, (kpt_num)]
+  implicit none
+  BEGIN_DOC
+  ! Number of deleted MOs
+  END_DOC
+  integer                        :: i,k,kshift
+
+  do k=1,kpt_num
+    n_del_orb_kpts(k) = 0
+    kshift = (1-k)*mo_num_per_kpt
+    do i = 1, mo_num_per_kpt
+      if(mo_class(i+kshift) == 'Deleted')then
+        n_del_orb_kpts(k) += 1
+      endif
+    enddo
+  enddo
+  
+!  call write_int(6,n_del_orb, 'Number of deleted  MOs')
+   
+END_PROVIDER
+
+BEGIN_PROVIDER [ integer, n_core_inact_orb_kpts, (kpt_num) ]
+  !todo: finish implementation for kpts (will need kpts_bitmask)
+  implicit none
+  BEGIN_DOC
+  ! n_core + n_inact
+  END_DOC
+  integer                        :: i,k
+  do k=1,kpt_num
+  n_core_inact_orb_kpts(k) = 0
+  do i = 1, N_int
+    n_core_inact_orb_kpts(k) += popcnt(iand(kpts_bitmask(i,k),reunion_of_core_inact_bitmask(i,1)))
+  enddo
+  enddo
+END_PROVIDER
+
+BEGIN_PROVIDER [integer, n_inact_act_orb_kpts, (kpt_num) ]
+   implicit none
+  BEGIN_DOC
+  ! n_inact + n_act
+  END_DOC
+  integer :: k
+  do k=1,kpt_num
+    n_inact_act_orb_kpts(k) = (n_inact_orb_kpts(k)+n_act_orb_kpts(k))
+  enddo
+END_PROVIDER
+ 
+BEGIN_PROVIDER [integer, dim_list_core_orb_kpts]
+  implicit none
+  BEGIN_DOC
+  ! dimensions for the allocation of list_core.
+  ! it is at least 1
+  END_DOC
+   dim_list_core_orb_kpts = max(maxval(n_core_orb_kpts),1)
+END_PROVIDER
+
+BEGIN_PROVIDER [integer, dim_list_inact_orb_kpts]
+   implicit none
+   BEGIN_DOC
+   ! dimensions for the allocation of list_inact.
+   ! it is at least 1
+   END_DOC
+   dim_list_inact_orb_kpts = max(maxval(n_inact_orb_kpts),1)
+END_PROVIDER
+
+BEGIN_PROVIDER [integer, dim_list_core_inact_orb_kpts]
+  implicit none
+  BEGIN_DOC
+  ! dimensions for the allocation of list_core.
+  ! it is at least 1
+  END_DOC
+   dim_list_core_inact_orb_kpts = max(maxval(n_core_inact_orb_kpts),1)
+END_PROVIDER
+
+BEGIN_PROVIDER [integer, dim_list_act_orb_kpts]
+   implicit none
+   BEGIN_DOC
+   ! dimensions for the allocation of list_act.
+   ! it is at least 1
+   END_DOC
+   dim_list_act_orb_kpts = max(maxval(n_act_orb_kpts),1)
+END_PROVIDER
+
+BEGIN_PROVIDER [integer, dim_list_virt_orb_kpts]
+   implicit none
+   BEGIN_DOC
+   ! dimensions for the allocation of list_virt.
+   ! it is at least 1
+   END_DOC
+   dim_list_virt_orb_kpts = max(maxval(n_virt_orb_kpts),1)
+END_PROVIDER
+
+BEGIN_PROVIDER [integer, dim_list_del_orb_kpts]
+   implicit none
+   BEGIN_DOC
+   ! dimensions for the allocation of list_del.
+   ! it is at least 1
+   END_DOC
+   dim_list_del_orb_kpts = max(maxval(n_del_orb_kpts),1)
+END_PROVIDER
+
+BEGIN_PROVIDER [integer, dim_list_core_inact_act_orb_kpts]
+   implicit none
+   BEGIN_DOC
+   ! dimensions for the allocation of list_core_inact_act.
+   ! it is at least 1
+   END_DOC
+   dim_list_core_inact_act_orb_kpts = max(maxval(n_core_inact_act_orb_kpts),1)
+END_PROVIDER
+
+BEGIN_PROVIDER [integer, dim_list_inact_act_orb_kpts]
+   implicit none
+   BEGIN_DOC
+   ! dimensions for the allocation of list_inact_act.
+   ! it is at least 1
+   END_DOC
+   dim_list_inact_act_orb_kpts = max(maxval(n_inact_act_orb_kpts),1)
+END_PROVIDER
+
+BEGIN_PROVIDER [integer, n_core_inact_act_orb_kpts, (kpt_num) ]
+  implicit none
+  BEGIN_DOC
+  !  Number of core inactive and active MOs
+  END_DOC
+  integer :: k
+  do k=1,kpt_num
+    n_core_inact_act_orb_kpts(k) = (n_core_orb_kpts(k) + n_inact_orb_kpts(k) + n_act_orb_kpts(k))
+  enddo
+END_PROVIDER
+ 
+
+
+
+BEGIN_PROVIDER [ integer(bit_kind), core_bitmask_kpts , (N_int,2,kpt_num) ]
+  implicit none
+  BEGIN_DOC
+  ! Bitmask identifying the core MOs 
+  END_DOC
+  integer :: k,i
+  core_bitmask_kpts  = 0_bit_kind
+  do k=1,kpt_num
+    do i=1,N_int
+      core_bitmask_kpts(i,1,k) = iand(core_bitmask(i,1),kpts_bitmask(i,k))
+      core_bitmask_kpts(i,2,k) = iand(core_bitmask(i,2),kpts_bitmask(i,k))
+    enddo
+  enddo
+END_PROVIDER
+
+BEGIN_PROVIDER [ integer(bit_kind), inact_bitmask_kpts , (N_int,2,kpt_num) ]
+  implicit none
+  BEGIN_DOC
+  ! Bitmask identifying the inactive MOs 
+  END_DOC
+  integer :: k,i
+  inact_bitmask_kpts  = 0_bit_kind
+  do k=1,kpt_num
+    do i=1,N_int
+      inact_bitmask_kpts(i,1,k) = iand(inact_bitmask(i,1),kpts_bitmask(i,k))
+      inact_bitmask_kpts(i,2,k) = iand(inact_bitmask(i,2),kpts_bitmask(i,k))
+    enddo
+  enddo
+END_PROVIDER
+
+BEGIN_PROVIDER [ integer(bit_kind), act_bitmask_kpts , (N_int,2,kpt_num) ]
+  implicit none
+  BEGIN_DOC
+  ! Bitmask identifying the active MOs 
+  END_DOC
+  integer :: k,i
+  act_bitmask_kpts  = 0_bit_kind
+  do k=1,kpt_num
+    do i=1,N_int
+      act_bitmask_kpts(i,1,k) = iand(act_bitmask(i,1),kpts_bitmask(i,k))
+      act_bitmask_kpts(i,2,k) = iand(act_bitmask(i,2),kpts_bitmask(i,k))
+    enddo
+  enddo
+END_PROVIDER
+
+BEGIN_PROVIDER [ integer(bit_kind), virt_bitmask_kpts , (N_int,2,kpt_num) ]
+  implicit none
+  BEGIN_DOC
+  ! Bitmask identifying the virtual MOs 
+  END_DOC
+  integer :: k,i
+  virt_bitmask_kpts  = 0_bit_kind
+  do k=1,kpt_num
+    do i=1,N_int
+      virt_bitmask_kpts(i,1,k) = iand(virt_bitmask(i,1),kpts_bitmask(i,k))
+      virt_bitmask_kpts(i,2,k) = iand(virt_bitmask(i,2),kpts_bitmask(i,k))
+    enddo
+  enddo
+END_PROVIDER
+
+BEGIN_PROVIDER [ integer(bit_kind), del_bitmask_kpts , (N_int,2,kpt_num) ]
+  implicit none
+  BEGIN_DOC
+  ! Bitmask identifying the deleted MOs 
+  END_DOC
+  integer :: k,i
+  del_bitmask_kpts  = 0_bit_kind
+  do k=1,kpt_num
+    do i=1,N_int
+      del_bitmask_kpts(i,1,k) = iand(del_bitmask(i,1),kpts_bitmask(i,k))
+      del_bitmask_kpts(i,2,k) = iand(del_bitmask(i,2),kpts_bitmask(i,k))
+    enddo
+  enddo
+END_PROVIDER
+
+ BEGIN_PROVIDER [ integer, list_core_kpts        , (dim_list_core_orb_kpts,kpt_num) ]
+&BEGIN_PROVIDER [ integer, list_core_kpts_reverse, (mo_num_per_kpt,kpt_num) ]
+   implicit none
+   BEGIN_DOC
+   ! List of MO indices which are in the core.
+   END_DOC
+   integer                        :: i, n,k,di
+   list_core_kpts = 0
+   list_core_kpts_reverse = 0
+
+   do k=1,kpt_num
+     n=0
+     di = (k-1)*mo_num_per_kpt
+     do i = 1, mo_num_per_kpt
+       if(mo_class(i+di) == 'Core')then
+         n += 1
+         list_core_kpts(n,k) = i
+         list_core_kpts_reverse(i,k) = n
+       endif
+     enddo
+     print *,  'Core MOs: ',k
+     print *,  list_core_kpts(1:n_core_orb_kpts(k),k)
+   enddo
+   
+END_PROVIDER
+ 
+ BEGIN_PROVIDER [ integer, list_inact_kpts        , (dim_list_inact_orb_kpts,kpt_num) ]
+&BEGIN_PROVIDER [ integer, list_inact_kpts_reverse, (mo_num_per_kpt,kpt_num) ]
+   implicit none
+   BEGIN_DOC
+   ! List of MO indices which are inactive.
+   END_DOC
+   integer                        :: i, n,k,di
+   list_inact_kpts = 0
+   list_inact_kpts_reverse = 0
+
+   do k=1,kpt_num
+     n=0
+     di = (k-1)*mo_num_per_kpt
+     do i = 1, mo_num_per_kpt
+       if(mo_class(i+di) == 'Inactive')then
+         n += 1
+         list_inact_kpts(n,k) = i
+         list_inact_kpts_reverse(i,k) = n
+       endif
+     enddo
+     print *,  'Inactive MOs: ',k
+     print *,  list_inact_kpts(1:n_inact_orb_kpts(k),k)
+   enddo
+   
+END_PROVIDER
+ 
+ BEGIN_PROVIDER [ integer, list_virt_kpts        , (dim_list_virt_orb_kpts,kpt_num) ]
+&BEGIN_PROVIDER [ integer, list_virt_kpts_reverse, (mo_num_per_kpt,kpt_num) ]
+   implicit none
+   BEGIN_DOC
+   ! List of MO indices which are virtual.
+   END_DOC
+   integer                        :: i, n,k,di
+   list_virt_kpts = 0
+   list_virt_kpts_reverse = 0
+
+   do k=1,kpt_num
+     n=0
+     di = (k-1)*mo_num_per_kpt
+     do i = 1, mo_num_per_kpt
+       if(mo_class(i+di) == 'Virtual')then
+         n += 1
+         list_virt_kpts(n,k) = i
+         list_virt_kpts_reverse(i,k) = n
+       endif
+     enddo
+     print *,  'Virtual MOs: ',k
+     print *,  list_virt_kpts(1:n_virt_orb_kpts(k),k)
+   enddo
+   
+END_PROVIDER
+ 
+ BEGIN_PROVIDER [ integer, list_del_kpts        , (dim_list_del_orb_kpts,kpt_num) ]
+&BEGIN_PROVIDER [ integer, list_del_kpts_reverse, (mo_num_per_kpt,kpt_num) ]
+   implicit none
+   BEGIN_DOC
+   ! List of MO indices which are deleted.
+   END_DOC
+   integer                        :: i, n,k,di
+   list_del_kpts = 0
+   list_del_kpts_reverse = 0
+
+   do k=1,kpt_num
+     n=0
+     di = (k-1)*mo_num_per_kpt
+     do i = 1, mo_num_per_kpt
+       if(mo_class(i+di) == 'Deleted')then
+         n += 1
+         list_del_kpts(n,k) = i
+         list_del_kpts_reverse(i,k) = n
+       endif
+     enddo
+     print *,  'Deleted MOs: ',k
+     print *,  list_del_kpts(1:n_del_orb_kpts(k),k)
+   enddo
+   
+END_PROVIDER
+ 
+ BEGIN_PROVIDER [ integer, list_act_kpts        , (dim_list_act_orb_kpts,kpt_num) ]
+&BEGIN_PROVIDER [ integer, list_act_kpts_reverse, (mo_num_per_kpt,kpt_num) ]
+   implicit none
+   BEGIN_DOC
+   ! List of MO indices which are active.
+   END_DOC
+   integer                        :: i, n,k,di
+   list_act_kpts = 0
+   list_act_kpts_reverse = 0
+
+   do k=1,kpt_num
+     n=0
+     di = (k-1)*mo_num_per_kpt
+     do i = 1, mo_num_per_kpt
+       if(mo_class(i+di) == 'Active')then
+         n += 1
+         list_act_kpts(n,k) = i
+         list_act_kpts_reverse(i,k) = n
+       endif
+     enddo
+     print *,  'Active MOs: ',k
+     print *,  list_act_kpts(1:n_act_orb_kpts(k),k)
+   enddo
+   
+END_PROVIDER
+
+!todo: finish below for kpts
+ 
+ BEGIN_PROVIDER [ integer, list_core_inact_kpts        , (dim_list_core_inact_orb_kpts,kpt_num) ]
+&BEGIN_PROVIDER [ integer, list_core_inact_kpts_reverse, (mo_num_per_kpt,kpt_num) ]
+  implicit none
+  BEGIN_DOC
+  ! List of indices of the core and inactive MOs
+  END_DOC
+  integer                        :: i,itmp,k
+  list_core_inact_kpts_reverse = 0
+  do k=1,kpt_num
+    !call bitstring_to_list(reunion_of_core_inact_bitmask(1,1), list_core_inact, itmp, N_int)
+    call bitstring_to_list(reunion_of_core_inact_bitmask_kpts(1,1,k), list_core_inact_kpts(1,k), itmp, N_int)
+    ASSERT (itmp == n_core_inact_orb_kpts(k))
+    do i = 1, n_core_inact_orb_kpts(k)
+      list_core_inact_kpts_reverse(list_core_inact_kpts(i,k),k) = i
+    enddo
+    print *,  'Core and Inactive MOs: ',k
+    print *,  list_core_inact_kpts(1:n_core_inact_orb_kpts(k),k)
+  enddo
+END_PROVIDER
+ 
+ 
+ BEGIN_PROVIDER [ integer, list_core_inact_act_kpts        , (dim_list_core_inact_act_orb_kpts,kpt_num) ]
+&BEGIN_PROVIDER [ integer, list_core_inact_act_kpts_reverse, (mo_num_per_kpt,kpt_num) ]
+  implicit none
+  BEGIN_DOC
+  ! List of indices of the core inactive and active MOs
+  END_DOC
+  integer                        :: i,itmp,k
+  list_core_inact_act_kpts_reverse = 0
+  do k=1,kpt_num
+    !call bitstring_to_list(reunion_of_core_inact_act_bitmask(1,1), list_core_inact_act, itmp, N_int)
+    call bitstring_to_list(reunion_of_core_inact_act_bitmask_kpts(1,1,k), list_core_inact_act_kpts(1,k), itmp, N_int)
+    ASSERT (itmp == n_core_inact_act_orb_kpts(k))
+    do i = 1, n_core_inact_act_orb_kpts(k)
+      list_core_inact_act_kpts_reverse(list_core_inact_act_kpts(i,k),k) = i
+    enddo
+    print *,  'Core, Inactive and Active MOs: ',k
+    print *,  list_core_inact_act_kpts(1:n_core_inact_act_orb_kpts(k),k)
+  enddo
+END_PROVIDER
+ 
+ 
+ BEGIN_PROVIDER [ integer, list_inact_act_kpts        , (dim_list_inact_act_orb_kpts,kpt_num) ]
+&BEGIN_PROVIDER [ integer, list_inact_act_kpts_reverse, (mo_num_per_kpt,kpt_num) ]
+   implicit none
+   BEGIN_DOC
+   ! List of indices of the inactive and active MOs
+   END_DOC
+   integer                        :: i,itmp,k
+   list_inact_act_kpts_reverse = 0
+   do k=1,kpt_num
+     call bitstring_to_list(reunion_of_inact_act_bitmask_kpts(1,1,k), list_inact_act_kpts(1,k), itmp, N_int)
+     ASSERT (itmp == n_inact_act_orb_kpts(k))
+     do i = 1, n_inact_act_orb_kpts(k)
+       list_inact_act_kpts_reverse(list_inact_act_kpts(i,k),k) = i
+     enddo
+     print *,  'Inactive and Active MOs: ',k
+     print *,  list_inact_act_kpts(1:n_inact_act_orb_kpts(k),k)
+   enddo
+END_PROVIDER
+ 

src/bitmask/track_orb.irp.f

@@ -0,0 +1,154 @@
+BEGIN_PROVIDER [ double precision, mo_coef_begin_iteration, (ao_num,mo_num) ]
+   implicit none
+   BEGIN_DOC
+   ! Void provider to store the coefficients of the |MO| basis at the beginning of the SCF iteration
+   !
+   ! Useful to track some orbitals
+   END_DOC
+END_PROVIDER
+
+BEGIN_PROVIDER [ complex*16, mo_coef_begin_iteration_complex, (ao_num,mo_num) ]
+   implicit none
+   BEGIN_DOC
+   ! Void provider to store the coefficients of the |MO| basis at the beginning of the SCF iteration
+   !
+   ! Useful to track some orbitals
+   END_DOC
+END_PROVIDER
+
+BEGIN_PROVIDER [ complex*16, mo_coef_begin_iteration_kpts, (ao_num_per_kpt,mo_num_per_kpt,kpt_num) ]
+   implicit none
+   BEGIN_DOC
+   ! Void provider to store the coefficients of the |MO| basis at the beginning of the SCF iteration
+   !
+   ! Useful to track some orbitals
+   END_DOC
+END_PROVIDER
+
+subroutine initialize_mo_coef_begin_iteration
+ implicit none
+ BEGIN_DOC
+ !
+ ! Initialize :c:data:`mo_coef_begin_iteration` to the current :c:data:`mo_coef`
+ END_DOC
+ if (is_complex) then
+   !mo_coef_begin_iteration_complex = mo_coef_complex
+   mo_coef_begin_iteration_kpts = mo_coef_kpts
+ else
+   mo_coef_begin_iteration = mo_coef
+ endif
+end
+
+subroutine reorder_core_orb
+  implicit none
+  BEGIN_DOC
+  ! TODO: test for complex
+ ! routines that takes the current :c:data:`mo_coef` and reorder the core orbitals (see :c:data:`list_core` and :c:data:`n_core_orb`) according to the overlap with :c:data:`mo_coef_begin_iteration`
+  END_DOC
+  integer :: i,j,iorb
+  integer :: k,l
+  integer, allocatable :: index_core_orb(:),iorder(:)
+  double precision, allocatable :: accu(:)
+  integer :: i1,i2
+  if (is_complex) then
+    complex*16, allocatable :: accu_c(:)
+    !allocate(accu(mo_num),accu_c(mo_num),index_core_orb(n_core_orb),iorder(mo_num))
+    !do i = 1, n_core_orb
+    !  iorb = list_core(i)
+    !  do j = 1, mo_num
+    !    accu(j) = 0.d0
+    !    accu_c(j) = (0.d0,0.d0)
+    !    iorder(j) = j
+    !    do k = 1, ao_num
+    !      do l = 1, ao_num
+    !        accu_c(j) += dconjg(mo_coef_begin_iteration_complex(k,iorb)) * &
+    !                     mo_coef_complex(l,j) * ao_overlap_complex(k,l)
+    !      enddo
+    !    enddo
+    !    accu(j) = -cdabs(accu_c(j))
+    !  enddo
+    !  call dsort(accu,iorder,mo_num)
+    !  index_core_orb(i) = iorder(1)
+    !enddo
+
+    !complex*16 :: x_c
+    !do j = 1, n_core_orb
+    !  i1 = list_core(j)
+    !  i2 = index_core_orb(j)
+    !  do i=1,ao_num
+    !     x_c = mo_coef_complex(i,i1)
+    !     mo_coef_complex(i,i1) = mo_coef_complex(i,i2)
+    !     mo_coef_complex(i,i2) = x_c
+    !  enddo
+    !enddo
+    !!call loc_cele_routine
+   
+    !deallocate(accu,accu_c,index_core_orb, iorder)
+    allocate(accu(mo_num_per_kpt),accu_c(mo_num_per_kpt),index_core_orb(n_core_orb),iorder(mo_num_per_kpt))
+    integer :: kk
+    do kk=1,kpt_num
+      do i = 1, n_core_orb_kpts(kk)
+        iorb = list_core_kpts(i,kk)
+        do j = 1, mo_num_per_kpt
+          accu(j) = 0.d0
+          accu_c(j) = (0.d0,0.d0)
+          iorder(j) = j
+          do k = 1, ao_num_per_kpt
+            do l = 1, ao_num_per_kpt
+              accu_c(j) += dconjg(mo_coef_begin_iteration_kpts(k,iorb,kk)) * &
+                           mo_coef_kpts(l,j,kk) * ao_overlap_kpts(k,l,kk)
+            enddo
+          enddo
+          accu(j) = -cdabs(accu_c(j))
+        enddo
+        call dsort(accu,iorder,mo_num_per_kpt)
+        index_core_orb(i) = iorder(1)
+      enddo
+
+      complex*16 :: x_c
+      do j = 1, n_core_orb
+        i1 = list_core_kpts(j,kk)
+        i2 = index_core_orb(j)
+        do i=1,ao_num_per_kpt
+           x_c = mo_coef_kpts(i,i1,kk)
+           mo_coef_kpts(i,i1,kk) = mo_coef_kpts(i,i2,kk)
+           mo_coef_kpts(i,i2,kk) = x_c
+        enddo
+      enddo
+      !call loc_cele_routine
+    enddo
+    deallocate(accu,accu_c,index_core_orb, iorder)
+  else
+    allocate(accu(mo_num),index_core_orb(n_core_orb),iorder(mo_num))
+   
+    do i = 1, n_core_orb
+      iorb = list_core(i)
+      do j = 1, mo_num
+        accu(j) = 0.d0
+        iorder(j) = j
+        do k = 1, ao_num
+          do l = 1, ao_num
+            accu(j) += mo_coef_begin_iteration(k,iorb) * mo_coef(l,j) * ao_overlap(k,l)
+          enddo
+        enddo
+        accu(j) = -dabs(accu(j))
+      enddo
+      call dsort(accu,iorder,mo_num)
+      index_core_orb(i) = iorder(1)
+    enddo
+   
+    double precision :: x
+    do j = 1, n_core_orb
+      i1 = list_core(j)
+      i2 = index_core_orb(j)
+      do i=1,ao_num
+         x = mo_coef(i,i1)
+         mo_coef(i,i1) = mo_coef(i,i2)
+         mo_coef(i,i2) = x
+      enddo
+    enddo
+    !call loc_cele_routine
+   
+    deallocate(accu,index_core_orb, iorder)
+  endif
+end

src/cipsi/cipsi.irp.f

@@ -20,7 +20,7 @@ subroutine run_cipsi
   logical                        :: has
   double precision               :: relative_error
 
-  PROVIDE H_apply_buffer_allocated
+  PROVIDE h_apply_buffer_allocated
 
   relative_error=PT2_relative_error
 
@@ -33,25 +33,39 @@ subroutine run_cipsi
   if (s2_eig) then
     call make_s2_eigenfunction
   endif
-  call diagonalize_CI
+  if (is_complex) then
+    call diagonalize_ci_complex
+  else
+    call diagonalize_CI
+  endif
   call save_wavefunction
 
   call ezfio_has_hartree_fock_energy(has)
   if (has) then
     call ezfio_get_hartree_fock_energy(hf_energy_ref)
   else
-    hf_energy_ref = ref_bitmask_energy
+    hf_energy_ref = ref_bitmask_energy_with_nucl_rep
   endif
 
   if (N_det > N_det_max) then
     psi_det = psi_det_sorted
-    psi_coef = psi_coef_sorted
-    N_det = N_det_max
-    soft_touch N_det psi_det psi_coef
+    if (is_complex) then
+      psi_coef_complex = psi_coef_sorted_complex
+      N_det = N_det_max
+      soft_touch N_det psi_det psi_coef_complex
+    else
+      psi_coef = psi_coef_sorted
+      N_det = N_det_max
+      soft_touch N_det psi_det psi_coef
+    endif
     if (s2_eig) then
       call make_s2_eigenfunction
     endif
-    call diagonalize_CI
+    if (is_complex) then
+      call diagonalize_CI_complex
+    else
+      call diagonalize_CI
+    endif
     call save_wavefunction
   endif
 
@@ -80,8 +94,13 @@ subroutine run_cipsi
       norm = 0.d0
       threshold_generators = 1.d0
       SOFT_TOUCH threshold_generators
-      call ZMQ_pt2(psi_energy_with_nucl_rep,pt2,relative_error,error, variance, &
-        norm, 0) ! Stochastic PT2
+!      if (is_complex) then
+!        call zmq_pt2_complex(psi_energy_with_nucl_rep,pt2,relative_error,error, variance, &
+!          norm, 0) ! Stochastic PT2
+!      else
+        call zmq_pt2(psi_energy_with_nucl_rep,pt2,relative_error,error, variance, &
+          norm, 0) ! Stochastic PT2
+!      endif
       threshold_generators = threshold_generators_save
       SOFT_TOUCH threshold_generators
     endif
@@ -108,13 +127,22 @@ subroutine run_cipsi
     n_det_before = N_det
     to_select = int(sqrt(dble(N_states))*dble(N_det)*selection_factor)
     to_select = max(N_states_diag, to_select)
-    call ZMQ_selection(to_select, pt2, variance, norm)
-
-    PROVIDE  psi_coef
+    call zmq_selection(to_select, pt2, variance, norm)
+    if (is_complex) then
+!      call zmq_selection_complex(to_select, pt2, variance, norm)
+      PROVIDE  psi_coef_complex
+    else
+!      call zmq_selection(to_select, pt2, variance, norm)
+      PROVIDE  psi_coef
+    endif
     PROVIDE  psi_det
     PROVIDE  psi_det_sorted
 
-    call diagonalize_CI
+    if (is_complex) then
+      call diagonalize_ci_complex
+    else
+      call diagonalize_CI
+    endif
     call save_wavefunction
     call save_energy(psi_energy_with_nucl_rep, zeros)
     if (qp_stop()) exit 
@@ -126,7 +154,11 @@ print *,  (correlation_energy_ratio <= correlation_energy_ratio_max)
 
   if (.not.qp_stop()) then
     if (N_det < N_det_max) then
-        call diagonalize_CI
+        if (is_complex) then
+          call diagonalize_ci_complex
+        else
+          call diagonalize_CI
+        endif
         call save_wavefunction
         call save_energy(psi_energy_with_nucl_rep, zeros)
     endif
@@ -137,8 +169,13 @@ print *,  (correlation_energy_ratio <= correlation_energy_ratio_max)
       norm(:) = 0.d0
       threshold_generators = 1d0
       SOFT_TOUCH threshold_generators
-      call ZMQ_pt2(psi_energy_with_nucl_rep, pt2,relative_error,error,variance, &
-        norm,0) ! Stochastic PT2
+!      if (is_complex) then
+!        call zmq_pt2_complex(psi_energy_with_nucl_rep, pt2,relative_error,error,variance, &
+!          norm,0) ! Stochastic PT2
+!      else
+        call ZMQ_pt2(psi_energy_with_nucl_rep, pt2,relative_error,error,variance, &
+          norm,0) ! Stochastic PT2
+!      endif
       SOFT_TOUCH threshold_generators
     endif
     print *,  'N_det             = ', N_det

src/cipsi/energy.irp.f

@@ -17,7 +17,11 @@ BEGIN_PROVIDER [ double precision, pt2_E0_denominator, (N_states) ]
      pt2_E0_denominator(1:N_states) = psi_energy(1:N_states)
    else if (h0_type == "HF") then
      do i=1,N_states
-       j = maxloc(abs(psi_coef(:,i)),1)
+       if (is_complex) then
+         j = maxloc(cdabs(psi_coef_complex(:,i)),1)
+       else
+         j = maxloc(abs(psi_coef(:,i)),1)
+       endif
        pt2_E0_denominator(i) = psi_det_hii(j)
      enddo
    else if (h0_type == "Barycentric") then

src/cipsi/pt2_stoch_routines.irp.f

@@ -11,7 +11,7 @@ END_PROVIDER
   implicit none
   logical, external :: testTeethBuilding
   integer :: i,j
-  pt2_n_tasks_max = elec_alpha_num*elec_alpha_num + elec_alpha_num*elec_beta_num  - n_core_orb*2 
+  pt2_n_tasks_max = elec_alpha_num*elec_alpha_num + elec_alpha_num*elec_beta_num  - n_core_orb*2
   pt2_n_tasks_max = min(pt2_n_tasks_max,1+N_det_generators/10000)
   call write_int(6,pt2_n_tasks_max,'pt2_n_tasks_max')
 
@@ -63,11 +63,19 @@ logical function testTeethBuilding(minF, N)
 
   norm = 0.d0
   double precision :: norm
-  do i=N_det_generators,1,-1
-    tilde_w(i)  = psi_coef_sorted_gen(i,pt2_stoch_istate) * &
-                  psi_coef_sorted_gen(i,pt2_stoch_istate)
-    norm = norm + tilde_w(i)
-  enddo
+  if (is_complex) then
+    do i=N_det_generators,1,-1
+      tilde_w(i)  = cdabs(psi_coef_sorted_gen_complex(i,pt2_stoch_istate) * &
+                    psi_coef_sorted_gen_complex(i,pt2_stoch_istate))
+      norm = norm + tilde_w(i)
+    enddo
+  else
+    do i=N_det_generators,1,-1
+      tilde_w(i)  = psi_coef_sorted_gen(i,pt2_stoch_istate) * &
+                    psi_coef_sorted_gen(i,pt2_stoch_istate)
+      norm = norm + tilde_w(i)
+    enddo
+  endif
 
   f = 1.d0/norm
   tilde_w(:) = tilde_w(:) * f
@@ -88,7 +96,7 @@ logical function testTeethBuilding(minF, N)
   do
     u0 = tilde_cW(n0)
     r = tilde_cW(n0 + minF)
-    Wt = (1d0 - u0) * f 
+    Wt = (1d0 - u0) * f
     if (dabs(Wt) <= 1.d-3) then
       exit
     endif
@@ -115,6 +123,7 @@ subroutine ZMQ_pt2(E, pt2,relative_error, error, variance, norm, N_in)
 
   integer(ZMQ_PTR)               :: zmq_to_qp_run_socket, zmq_socket_pull
   integer, intent(in)            :: N_in
+!  integer, intent(inout)         :: N_in
   double precision, intent(in)   :: relative_error, E(N_states)
   double precision, intent(out)  :: pt2(N_states),error(N_states)
   double precision, intent(out)  :: variance(N_states),norm(N_states)
@@ -126,21 +135,29 @@ subroutine ZMQ_pt2(E, pt2,relative_error, error, variance, norm, N_in)
   integer(ZMQ_PTR), external     :: new_zmq_to_qp_run_socket
   type(selection_buffer)         :: b
 
-  PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
-  PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
-  PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
-  PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp psi_det_sorted
-  PROVIDE psi_det_hii selection_weight pseudo_sym
+  if (is_complex) then
+    PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
+    PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
+    PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
+    PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp_complex psi_det_sorted
+    PROVIDE psi_det_hii selection_weight pseudo_sym
+  else
+    PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
+    PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
+    PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
+    PROVIDE psi_bilinear_matrix_transp_order psi_selectors_coef_transp psi_det_sorted
+    PROVIDE psi_det_hii selection_weight pseudo_sym
+  endif
 
   if (h0_type == 'SOP') then
     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) .or. pt2_N_teeth < 2) then
     pt2=0.d0
     variance=0.d0
     norm=0.d0
-    call ZMQ_selection(N_in, pt2, variance, norm)
+    call zmq_selection(N_in, pt2, variance, norm)
     error(:) = 0.d0
   else
 
@@ -159,8 +176,16 @@ subroutine ZMQ_pt2(E, pt2,relative_error, error, variance, norm, N_in)
       state_average_weight(pt2_stoch_istate) = 1.d0
       TOUCH state_average_weight pt2_stoch_istate selection_weight
 
-      PROVIDE nproc pt2_F mo_two_e_integrals_in_map mo_one_e_integrals pt2_w
-      PROVIDE psi_selectors pt2_u pt2_J pt2_R
+      if (is_complex) then
+        !todo: psi_selectors isn't linked to psi_selectors_coef anymore; should we provide both?
+        !PROVIDE nproc pt2_F mo_two_e_integrals_in_map mo_one_e_integrals_complex pt2_w
+        PROVIDE nproc pt2_F mo_two_e_integrals_in_map mo_one_e_integrals_kpts pt2_w
+        PROVIDE psi_selectors pt2_u pt2_J pt2_R
+      else
+        PROVIDE nproc pt2_F mo_two_e_integrals_in_map mo_one_e_integrals pt2_w
+        PROVIDE psi_selectors pt2_u pt2_J pt2_R
+      endif
+
       call new_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'pt2')
 
       integer, external              :: zmq_put_psi
@@ -272,6 +297,10 @@ subroutine ZMQ_pt2(E, pt2,relative_error, error, variance, norm, N_in)
               + 2.0d0*(N_int*2*ii)              & ! minilist, fullminilist
               + 1.0d0*(N_states*mo_num*mo_num)  & ! mat
               ) / 1024.d0**3
+        if (is_complex) then
+          ! mat is complex
+          mem = mem + (nproc_target*8.d0*(N_states*mo_num* mo_num)) / 1024.d0**3
+        endif
 
         if (nproc_target == 0) then
           call check_mem(mem,irp_here)
@@ -296,7 +325,7 @@ subroutine ZMQ_pt2(E, pt2,relative_error, error, variance, norm, N_in)
       print '(A)', ' Samples        Energy        Stat. Err     Variance          Norm          Seconds      '
       print '(A)', '========== ================= =========== =============== =============== ================='
 
-      PROVIDE global_selection_buffer 
+      PROVIDE global_selection_buffer
       !$OMP PARALLEL DEFAULT(shared) NUM_THREADS(nproc_target+1)            &
           !$OMP  PRIVATE(i)
       i = omp_get_thread_num()
@@ -346,7 +375,7 @@ subroutine pt2_slave_inproc(i)
   implicit none
   integer, intent(in)            :: i
 
-  PROVIDE global_selection_buffer 
+  PROVIDE global_selection_buffer
   call run_pt2_slave(1,i,pt2_e0_denominator)
 end
 
@@ -528,8 +557,8 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2, error, varianc
        print*,'PB !!!'
        print*,'If you see this, send an email to Anthony scemama with the following content'
        print*,irp_here
-       print*,'n_tasks,pt2_n_tasks_max = ',n_tasks,pt2_n_tasks_max  
-       stop -1 
+       print*,'n_tasks,pt2_n_tasks_max = ',n_tasks,pt2_n_tasks_max
+       stop -1
       endif
       if (zmq_delete_tasks_async_send(zmq_to_qp_run_socket,task_id,n_tasks,sending) == -1) then
           stop 'PT2: Unable to delete tasks (send)'
@@ -540,7 +569,7 @@ subroutine pt2_collector(zmq_socket_pull, E, relative_error, pt2, error, varianc
          print*,'If you see this, send an email to Anthony scemama with the following content'
          print*,irp_here
          print*,'i,index(i),size(ei,2) = ',i,index(i),size(ei,2)
-         stop -1 
+         stop -1
         endif
         eI(1:N_states, index(i)) += eI_task(1:N_states,i)
         vI(1:N_states, index(i)) += vI_task(1:N_states,i)
@@ -731,39 +760,45 @@ END_PROVIDER
    double precision, allocatable  :: tilde_w(:), tilde_cW(:)
    double precision               :: r, tooth_width
    integer, external              :: pt2_find_sample
-   
+
    double precision               :: rss
    double precision, external     :: memory_of_double, memory_of_int
    rss = memory_of_double(2*N_det_generators+1)
    call check_mem(rss,irp_here)
-   
+
    if (N_det_generators == 1) then
-     
+
      pt2_w(1)   = 1.d0
      pt2_cw(1)  = 1.d0
      pt2_u_0    = 1.d0
      pt2_W_T    = 0.d0
      pt2_n_0(1) = 0
      pt2_n_0(2) = 1
-     
+
    else
-     
+
      allocate(tilde_w(N_det_generators), tilde_cW(0:N_det_generators))
-     
+
      tilde_cW(0) = 0d0
-     
-     do i=1,N_det_generators
-       tilde_w(i)  = psi_coef_sorted_gen(i,pt2_stoch_istate)**2 !+ 1.d-20
-     enddo
+    
+     if (is_complex) then
+       do i=1,N_det_generators
+         tilde_w(i)  = cdabs(psi_coef_sorted_gen_complex(i,pt2_stoch_istate))**2 !+ 1.d-20
+       enddo
+     else
+       do i=1,N_det_generators
+         tilde_w(i)  = psi_coef_sorted_gen(i,pt2_stoch_istate)**2 !+ 1.d-20
+       enddo
+     endif
      
      double precision               :: norm
      norm = 0.d0
      do i=N_det_generators,1,-1
        norm += tilde_w(i)
      enddo
-     
+
      tilde_w(:) = tilde_w(:) / norm
-     
+
      tilde_cW(0) = -1.d0
      do i=1,N_det_generators
        tilde_cW(i) = tilde_cW(i-1) + tilde_w(i)
@@ -773,7 +808,7 @@ END_PROVIDER
      pt2_n_0(1) = 0
      do
      pt2_u_0 = tilde_cW(pt2_n_0(1))
-     r = tilde_cW(pt2_n_0(1) + pt2_minDetInFirstTeeth)
+     r = tilde_cW(pt2_n_0(1) + pt2_mindetinfirstteeth)
      pt2_W_T = (1d0 - pt2_u_0) / dble(pt2_N_teeth)
      if(pt2_W_T >= r - pt2_u_0) then
        exit
@@ -784,13 +819,13 @@ END_PROVIDER
        stop -1
      end if
    end do
-   
+
    do t=2, pt2_N_teeth
      r = pt2_u_0 + pt2_W_T * dble(t-1)
      pt2_n_0(t) = pt2_find_sample(r, tilde_cW)
    end do
    pt2_n_0(pt2_N_teeth+1) = N_det_generators
-   
+
    pt2_w(:pt2_n_0(1)) = tilde_w(:pt2_n_0(1))
    do t=1, pt2_N_teeth
      tooth_width = tilde_cW(pt2_n_0(t+1)) - tilde_cW(pt2_n_0(t))
@@ -799,10 +834,10 @@ END_PROVIDER
      endif
      ASSERT(tooth_width > 0.d0)
      do i=pt2_n_0(t)+1, pt2_n_0(t+1)
-       pt2_w(i) = tilde_w(i) * pt2_W_T / tooth_width
+       pt2_w(i) = tilde_w(i) * pt2_w_t / tooth_width
      end do
    end do
-   
+
    pt2_cW(0) = 0d0
    do i=1,N_det_generators
      pt2_cW(i) = pt2_cW(i-1) + pt2_w(i)
@@ -813,6 +848,3 @@ END_PROVIDER
 END_PROVIDER
 
 
-
-
-

src/cipsi/run_selection_slave.irp.f

@@ -21,12 +21,17 @@ subroutine run_selection_slave(thread,iproc,energy)
   double precision :: pt2(N_states)
   double precision :: variance(N_states)
   double precision :: norm(N_states)
-
+  
+  !todo: check for providers that are now unlinked for real/complex
   PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
   PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
   PROVIDE psi_bilinear_matrix_transp_rows_loc psi_bilinear_matrix_transp_columns
   PROVIDE psi_bilinear_matrix_transp_order N_int pt2_F pseudo_sym
-  PROVIDE psi_selectors_coef_transp psi_det_sorted weight_selection
+  if (is_complex) then
+    PROVIDE psi_selectors_coef_transp_complex psi_det_sorted weight_selection
+  else
+    PROVIDE psi_selectors_coef_transp psi_det_sorted weight_selection
+  endif
 
 
   zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
@@ -99,6 +104,17 @@ subroutine run_selection_slave(thread,iproc,energy)
     ctask = ctask + 1
   end do
 
+  if(ctask > 0) then
+    call sort_selection_buffer(buf)
+!    call merge_selection_buffers(buf,buf2)
+    call push_selection_results(zmq_socket_push, pt2, variance, norm, buf, task_id(1), ctask)
+!    buf%mini = buf2%mini
+    pt2(:) = 0d0
+    variance(:) = 0d0
+    norm(:) = 0d0
+    buf%cur = 0
+  end if
+  ctask = 0
 
   integer, external :: disconnect_from_taskserver
   if (disconnect_from_taskserver(zmq_to_qp_run_socket,worker_id) == -1) then

src/cipsi/slave_cipsi.irp.f

@@ -14,10 +14,17 @@ subroutine run_slave_cipsi
 end
 
 subroutine provide_everything
-  PROVIDE H_apply_buffer_allocated mo_two_e_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context N_states_diag
-  PROVIDE pt2_e0_denominator mo_num N_int ci_energy mpi_master zmq_state zmq_context
-  PROVIDE psi_det psi_coef threshold_generators state_average_weight
-  PROVIDE N_det_selectors pt2_stoch_istate N_det selection_weight pseudo_sym
+  if (is_complex) then
+    PROVIDE H_apply_buffer_allocated mo_two_e_integrals_in_map psi_det_generators psi_coef_generators_complex psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context N_states_diag
+    PROVIDE pt2_e0_denominator mo_num_per_kpt N_int ci_energy mpi_master zmq_state zmq_context
+    PROVIDE psi_det psi_coef_complex threshold_generators state_average_weight
+    PROVIDE N_det_selectors pt2_stoch_istate N_det selection_weight pseudo_sym
+  else
+    PROVIDE H_apply_buffer_allocated mo_two_e_integrals_in_map psi_det_generators psi_coef_generators psi_det_sorted_bit psi_selectors n_det_generators n_states generators_bitmask zmq_context N_states_diag
+    PROVIDE pt2_e0_denominator mo_num N_int ci_energy mpi_master zmq_state zmq_context
+    PROVIDE psi_det psi_coef threshold_generators state_average_weight
+    PROVIDE N_det_selectors pt2_stoch_istate N_det selection_weight pseudo_sym
+  endif
 end
 
 subroutine run_slave_main
@@ -51,9 +58,15 @@ subroutine run_slave_main
 
   zmq_to_qp_run_socket = new_zmq_to_qp_run_socket()
 
-  PROVIDE psi_det psi_coef threshold_generators state_average_weight mpi_master
-  PROVIDE zmq_state N_det_selectors pt2_stoch_istate N_det pt2_e0_denominator
-  PROVIDE N_det_generators N_states N_states_diag pt2_e0_denominator mpi_rank
+  if (is_complex) then
+    PROVIDE psi_det psi_coef_complex threshold_generators state_average_weight mpi_master
+    PROVIDE zmq_state N_det_selectors pt2_stoch_istate N_det pt2_e0_denominator
+    PROVIDE N_det_generators N_states N_states_diag pt2_e0_denominator mpi_rank
+  else
+    PROVIDE psi_det psi_coef threshold_generators state_average_weight mpi_master
+    PROVIDE zmq_state N_det_selectors pt2_stoch_istate N_det pt2_e0_denominator
+    PROVIDE N_det_generators N_states N_states_diag pt2_e0_denominator mpi_rank
+  endif
 
   IRP_IF MPI
     call MPI_BARRIER(MPI_COMM_WORLD, ierr)
@@ -268,6 +281,10 @@ subroutine run_slave_main
                 + 2.0d0*(N_int*2*ii)              & ! minilist, fullminilist
                 + 1.0d0*(N_states*mo_num*mo_num)  & ! mat
                 ) / 1024.d0**3
+          if (is_complex) then
+            ! mat is complex
+            mem = mem + (nproc_target * 8.d0 * (n_states*mo_num*mo_num)) / 1024.d0**3
+          endif
 
           if (nproc_target == 0) then
             call check_mem(mem,irp_here)

src/cipsi/stochastic_cipsi.irp.f

@@ -36,25 +36,39 @@ subroutine run_stochastic_cipsi
   if (s2_eig) then
     call make_s2_eigenfunction
   endif
-  call diagonalize_CI
+  if (is_complex) then
+    call diagonalize_ci_complex
+  else
+    call diagonalize_ci
+  endif
   call save_wavefunction
 
   call ezfio_has_hartree_fock_energy(has)
   if (has) then
     call ezfio_get_hartree_fock_energy(hf_energy_ref)
   else
-    hf_energy_ref = ref_bitmask_energy
+    hf_energy_ref = ref_bitmask_energy_with_nucl_rep
   endif
 
   if (N_det > N_det_max) then
     psi_det = psi_det_sorted
-    psi_coef = psi_coef_sorted
-    N_det = N_det_max
-    soft_touch N_det psi_det psi_coef
+    if (is_complex) then
+      psi_coef_complex = psi_coef_sorted_complex
+      N_det = N_det_max
+      soft_touch N_det psi_det psi_coef_complex
+    else
+      psi_coef = psi_coef_sorted
+      N_det = N_det_max
+      soft_touch N_det psi_det psi_coef
+    endif
     if (s2_eig) then
       call make_s2_eigenfunction
     endif
-    call diagonalize_CI
+    if (is_complex) then
+      call diagonalize_ci_complex
+    else
+      call diagonalize_CI
+    endif
     call save_wavefunction
   endif
 
@@ -78,8 +92,13 @@ subroutine run_stochastic_cipsi
     pt2 = 0.d0
     variance = 0.d0
     norm = 0.d0
-    call ZMQ_pt2(psi_energy_with_nucl_rep,pt2,relative_error,error, variance, &
-      norm, to_select) ! Stochastic PT2 and selection
+!    if (is_complex) then
+!      call zmq_pt2_complex(psi_energy_with_nucl_rep,pt2,relative_error,error, variance, &
+!        norm, to_select) ! Stochastic PT2 and selection
+!    else
+      call zmq_pt2(psi_energy_with_nucl_rep,pt2,relative_error,error, variance, &
+        norm, to_select) ! Stochastic PT2 and selection
+!    endif
 
     do k=1,N_states
       rpt2(k) = pt2(k)/(1.d0 + norm(k))
@@ -91,6 +110,7 @@ subroutine run_stochastic_cipsi
 
     call write_double(6,correlation_energy_ratio, 'Correlation ratio')
     call print_summary(psi_energy_with_nucl_rep,pt2,error,variance,norm,N_det,N_occ_pattern,N_states,psi_s2)
+    !call print_debug_fci()
 
     call save_energy(psi_energy_with_nucl_rep, rpt2)
 
@@ -101,14 +121,22 @@ subroutine run_stochastic_cipsi
     if (qp_stop()) exit 
 
     ! Add selected determinants
-    call copy_H_apply_buffer_to_wf()
+    call copy_h_apply_buffer_to_wf()
 !    call save_wavefunction
 
-    PROVIDE  psi_coef
+    if (is_complex) then
+      PROVIDE  psi_coef_complex
+    else
+      PROVIDE  psi_coef
+    endif
     PROVIDE  psi_det
     PROVIDE  psi_det_sorted
 
-    call diagonalize_CI
+    if (is_complex) then
+      call diagonalize_ci_complex
+    else
+      call diagonalize_CI
+    endif
     call save_wavefunction
     call save_energy(psi_energy_with_nucl_rep, zeros)
     if (qp_stop()) exit 
@@ -116,7 +144,11 @@ subroutine run_stochastic_cipsi
 
   if (.not.qp_stop()) then
     if (N_det < N_det_max) then
-        call diagonalize_CI
+        if (is_complex) then
+          call diagonalize_ci_complex
+        else
+          call diagonalize_CI
+        endif
         call save_wavefunction
         call save_energy(psi_energy_with_nucl_rep, zeros)
     endif
@@ -124,8 +156,13 @@ subroutine run_stochastic_cipsi
     pt2(:) = 0.d0
     variance(:) = 0.d0
     norm(:) = 0.d0
-    call ZMQ_pt2(psi_energy_with_nucl_rep, pt2,relative_error,error,variance, &
-      norm,0) ! Stochastic PT2
+  !  if (is_complex) then
+  !    call zmq_pt2_complex(psi_energy_with_nucl_rep, pt2,relative_error,error,variance, &
+  !      norm,0) ! Stochastic PT2
+  !  else
+      call ZMQ_pt2(psi_energy_with_nucl_rep, pt2,relative_error,error,variance, &
+        norm,0) ! Stochastic PT2
+  !  endif
 
     do k=1,N_states
       rpt2(k) = pt2(k)/(1.d0 + norm(k))

src/cipsi/zmq_selection.irp.f

@@ -17,6 +17,7 @@ subroutine ZMQ_selection(N_in, pt2, variance, norm)
 
   N = max(N_in,1)
   if (.True.) then
+    !todo: some providers have become unlinked for real/complex (det/coef); do these need to be provided?
     PROVIDE pt2_e0_denominator nproc
     PROVIDE psi_bilinear_matrix_columns_loc psi_det_alpha_unique psi_det_beta_unique
     PROVIDE psi_bilinear_matrix_rows psi_det_sorted_order psi_bilinear_matrix_order
@@ -105,9 +106,16 @@ subroutine ZMQ_selection(N_in, pt2, variance, norm)
   f(:) = 1.d0
   if (.not.do_pt2) then
   double precision :: f(N_states), u_dot_u
-    do k=1,min(N_det,N_states)
-     f(k) = 1.d0 / u_dot_u(psi_selectors_coef(1,k), N_det_selectors)
-    enddo
+    if (is_complex) then
+      double precision :: u_dot_u_complex
+      do k=1,min(N_det,N_states)
+       f(k) = 1.d0 / u_dot_u_complex(psi_selectors_coef_complex(1,k), N_det_selectors)
+      enddo
+    else
+      do k=1,min(N_det,N_states)
+       f(k) = 1.d0 / u_dot_u(psi_selectors_coef(1,k), N_det_selectors)
+      enddo
+    endif
   endif
 
   !$OMP PARALLEL DEFAULT(shared)  SHARED(b, pt2, variance, norm)  PRIVATE(i) NUM_THREADS(nproc_target+1)
@@ -224,3 +232,4 @@ subroutine selection_collector(zmq_socket_pull, b, N, pt2, variance, norm)
   call end_zmq_to_qp_run_socket(zmq_to_qp_run_socket)
 end subroutine
 
+

src/davidson/davidson_parallel.irp.f

@@ -89,21 +89,97 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze,
   character*(512)                :: msg
   integer                        :: imin, imax, ishift, istep
 
-  integer, allocatable           :: psi_det_read(:,:,:)
-  double precision, allocatable  :: v_t(:,:), s_t(:,:), u_t(:,:)
-
-  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t, v_t, s_t
-
-  ! Get wave function (u_t)
-  ! -----------------------
-
   integer                        :: rc, ni, nj
   integer*8                      :: rc8
   integer                        :: N_states_read, N_det_read, psi_det_size_read
   integer                        :: N_det_selectors_read, N_det_generators_read
 
-  integer, external :: zmq_get_dvector
+  integer, allocatable           :: psi_det_read(:,:,:)
+  logical :: sending
+  integer, external :: get_task_from_taskserver
+  integer, external :: task_done_to_taskserver
+  integer :: k
+  integer :: ierr
+ 
+
+!  integer, external :: zmq_get_dvector
   integer, external :: zmq_get_dmatrix
+  integer, external :: zmq_get_cdmatrix
+  IRP_IF MPI
+    include 'mpif.h'
+  IRP_ENDIF
+ 
+  if (is_complex) then
+    complex*16, allocatable  :: v_tc(:,:), s_tc(:,:), u_tc(:,:)
+
+    !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_tc, v_tc, s_tc
+
+
+    ! Get wave function (u_tc)
+    ! -----------------------
+
+    PROVIDE psi_det_beta_unique psi_bilinear_matrix_order_transp_reverse psi_det_alpha_unique
+    PROVIDE psi_bilinear_matrix_transp_values_complex psi_bilinear_matrix_values_complex psi_bilinear_matrix_columns_loc
+    PROVIDE ref_bitmask_energy nproc
+    PROVIDE mpi_initialized
+
+    allocate(u_tc(N_st,N_det))
+    
+    !todo: resize for complex? (should be okay)
+    ! Warning : dimensions are modified for efficiency, It is OK since we get the
+    ! full matrix
+    if (size(u_tc,kind=8) < 8388608_8) then
+      ni = size(u_tc)
+      nj = 1
+    else
+      ni = 8388608
+      nj = int(size(u_tc,kind=8)/8388608_8,4) + 1
+    endif
+
+    do while (zmq_get_cdmatrix(zmq_to_qp_run_socket, worker_id, 'u_tc', u_tc, ni, nj, size(u_tc,kind=8)) == -1)
+      print *,  'mpi_rank, N_states_diag, N_det'
+      print *,  mpi_rank, N_states_diag, N_det
+      stop 'u_tc'
+    enddo
+
+    IRP_IF MPI
+!      include 'mpif.h'
+      call broadcast_chunks_complex_double(u_tc,size(u_tc,kind=8))
+    IRP_ENDIF
+
+    ! Run tasks
+    ! ---------
+
+    sending=.False.
+
+    allocate(v_tc(N_st,N_det), s_tc(N_st,N_det))
+    do
+      if (get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, msg) == -1) then
+        exit
+      endif
+      if(task_id == 0) exit
+      read (msg,*) imin, imax, ishift, istep
+      do k=imin,imax
+        v_tc(:,k) = (0.d0,0.d0)
+        s_tc(:,k) = (0.d0,0.d0)
+      enddo
+      call h_s2_u_0_nstates_openmp_work_complex(v_tc,s_tc,u_tc,N_st,N_det,imin,imax,ishift,istep)
+      if (task_done_to_taskserver(zmq_to_qp_run_socket,worker_id,task_id) == -1) then
+          print *,  irp_here, 'Unable to send task_done'
+      endif
+      call davidson_push_results_async_recv(zmq_socket_push, sending)
+      call davidson_push_results_async_send_complex(zmq_socket_push, v_tc, s_tc, imin, imax, task_id, sending)
+    end do
+    deallocate(u_tc,v_tc, s_tc)
+    call davidson_push_results_async_recv(zmq_socket_push, sending)
+  else
+  double precision, allocatable  :: v_t(:,:), s_t(:,:), u_t(:,:)
+
+  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t, v_t, s_t
+
+
+  ! Get wave function (u_t)
+  ! -----------------------
 
   PROVIDE psi_det_beta_unique psi_bilinear_matrix_order_transp_reverse psi_det_alpha_unique
   PROVIDE psi_bilinear_matrix_transp_values psi_bilinear_matrix_values psi_bilinear_matrix_columns_loc
@@ -129,29 +205,22 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze,
   enddo
 
   IRP_IF MPI
-    include 'mpif.h'
-    integer :: ierr
-
+    !include 'mpif.h'
     call broadcast_chunks_double(u_t,size(u_t,kind=8))
-
   IRP_ENDIF
 
   ! Run tasks
   ! ---------
 
-  logical :: sending
   sending=.False.
 
   allocate(v_t(N_st,N_det), s_t(N_st,N_det))
   do
-    integer, external :: get_task_from_taskserver
-    integer, external :: task_done_to_taskserver
     if (get_task_from_taskserver(zmq_to_qp_run_socket,worker_id, task_id, msg) == -1) then
       exit
     endif
     if(task_id == 0) exit
     read (msg,*) imin, imax, ishift, istep
-    integer :: k
     do k=imin,imax
       v_t(:,k) = 0.d0
       s_t(:,k) = 0.d0
@@ -165,7 +234,7 @@ subroutine davidson_slave_work(zmq_to_qp_run_socket, zmq_socket_push, N_st, sze,
   end do
   deallocate(u_t,v_t, s_t)
   call davidson_push_results_async_recv(zmq_socket_push, sending)
-
+  endif
 end subroutine
 
 
@@ -533,6 +602,7 @@ subroutine H_S2_u_0_nstates_zmq(v_0,s_0,u_0,N_st,sze)
 end
 
 
+
 BEGIN_PROVIDER [ integer, nthreads_davidson ]
  implicit none
  BEGIN_DOC
@@ -643,3 +713,360 @@ integer function zmq_get_N_states_diag(zmq_to_qp_run_socket, worker_id)
   IRP_ENDIF
 end
 
+
+!==============================================================================!
+!                                                                              !
+!                                    Complex                                   !
+!                                                                              !
+!==============================================================================!
+
+subroutine davidson_push_results_complex(zmq_socket_push, v_t, s_t, imin, imax, task_id)
+  use f77_zmq
+  implicit none
+  BEGIN_DOC
+! Push the results of $H | U \rangle$ from a worker to the master.
+  END_DOC
+
+  integer(ZMQ_PTR)    ,intent(in)    :: zmq_socket_push
+  integer             ,intent(in)    :: task_id, imin, imax
+  complex*16          ,intent(in)    :: v_t(N_states_diag,N_det)
+  complex*16          ,intent(in)    :: s_t(N_states_diag,N_det)
+  integer                            :: rc, sz
+  integer*8                          :: rc8
+
+  sz = (imax-imin+1)*N_states_diag
+
+  rc = f77_zmq_send( zmq_socket_push, task_id, 4, ZMQ_SNDMORE)
+  if(rc /= 4) stop 'davidson_push_results_complex failed to push task_id'
+
+  rc = f77_zmq_send( zmq_socket_push, imin, 4, ZMQ_SNDMORE)
+  if(rc /= 4) stop 'davidson_push_results_complex failed to push imin'
+
+  rc = f77_zmq_send( zmq_socket_push, imax, 4, ZMQ_SNDMORE)
+  if(rc /= 4) stop 'davidson_push_results_complex failed to push imax'
+
+  !todo: double sz for complex? (done)
+  rc8 = f77_zmq_send8( zmq_socket_push, v_t(1,imin), 8_8*sz*2, ZMQ_SNDMORE)
+  if(rc8 /= 8_8*sz*2) then
+    print*,irp_here,' rc8 = ',rc8
+    print*,irp_here,'  sz = ',sz
+    print*,'rc8 /= sz*8'
+    stop 'davidson_push_results_complex failed to push vt'
+  endif
+
+  !todo: double sz for complex? (done)
+  rc8 = f77_zmq_send8( zmq_socket_push, s_t(1,imin), 8_8*sz*2, 0)
+  if(rc8 /= 8_8*sz*2) stop 'davidson_push_results_complex failed to push st'
+
+! Activate is zmq_socket_push is a REQ
+IRP_IF ZMQ_PUSH
+IRP_ELSE
+  character*(2) :: ok
+  rc = f77_zmq_recv( zmq_socket_push, ok, 2, 0)
+  if ((rc /= 2).and.(ok(1:2)/='ok')) then
+    print *, irp_here, ': f77_zmq_recv( zmq_socket_push, ok, 2, 0)'
+    stop -1
+  endif
+IRP_ENDIF
+
+end subroutine
+
+subroutine davidson_push_results_async_send_complex(zmq_socket_push, v_t, s_t, imin, imax, task_id,sending)
+  use f77_zmq
+  implicit none
+  BEGIN_DOC
+! Push the results of $H | U \rangle$ from a worker to the master.
+  END_DOC
+
+  integer(ZMQ_PTR)    ,intent(in)    :: zmq_socket_push
+  integer             ,intent(in)    :: task_id, imin, imax
+  complex*16          ,intent(in)    :: v_t(N_states_diag,N_det)
+  complex*16          ,intent(in)    :: s_t(N_states_diag,N_det)
+  logical             ,intent(inout) :: sending
+  integer                            :: rc, sz
+  integer*8                          :: rc8
+
+  if (sending) then
+    print *,  irp_here, ': sending=true'
+    stop -1
+  endif
+  sending = .True.
+
+  sz = (imax-imin+1)*N_states_diag
+
+  rc = f77_zmq_send( zmq_socket_push, task_id, 4, ZMQ_SNDMORE)
+  if(rc /= 4) stop 'davidson_push_results_async_send_complex failed to push task_id'
+
+  rc = f77_zmq_send( zmq_socket_push, imin, 4, ZMQ_SNDMORE)
+  if(rc /= 4) stop 'davidson_push_results_async_send_complex failed to push imin'
+
+  rc = f77_zmq_send( zmq_socket_push, imax, 4, ZMQ_SNDMORE)
+  if(rc /= 4) stop 'davidson_push_results_async_send_complex failed to push imax'
+
+  !todo: double sz for complex? (done)
+  rc8 = f77_zmq_send8( zmq_socket_push, v_t(1,imin), 8_8*sz*2, ZMQ_SNDMORE)
+  if(rc8 /= 8_8*sz*2) then
+    print*,irp_here,' rc8 = ',rc8
+    print*,irp_here,'  sz = ',sz
+    print*,'rc8 /= sz*8'
+    stop 'davidson_push_results_async_send_complex failed to push vt'
+  endif
+
+  !todo: double sz for complex? (done)
+  rc8 = f77_zmq_send8( zmq_socket_push, s_t(1,imin), 8_8*sz*2, 0)
+  if(rc8 /= 8_8*sz*2) stop 'davidson_push_results_async_send_complex failed to push st'
+
+end subroutine
+
+
+subroutine davidson_pull_results_complex(zmq_socket_pull, v_t, s_t, imin, imax, task_id)
+  use f77_zmq
+  implicit none
+  BEGIN_DOC
+! Pull the results of $H | U \rangle$ on the master.
+  END_DOC
+
+  integer(ZMQ_PTR)    ,intent(in)     :: zmq_socket_pull
+  integer             ,intent(out)    :: task_id, imin, imax
+  complex*16          ,intent(out)    :: v_t(N_states_diag,N_det)
+  complex*16          ,intent(out)    :: s_t(N_states_diag,N_det)
+
+  integer                            :: rc, sz
+  integer*8                          :: rc8
+
+  rc = f77_zmq_recv( zmq_socket_pull, task_id, 4, 0)
+  if(rc /= 4) stop 'davidson_pull_results failed to pull task_id'
+
+  rc = f77_zmq_recv( zmq_socket_pull, imin, 4, 0)
+  if(rc /= 4) stop 'davidson_pull_results failed to pull imin'
+
+  rc = f77_zmq_recv( zmq_socket_pull, imax, 4, 0)
+  if(rc /= 4) stop 'davidson_pull_results failed to pull imax'
+
+  sz = (imax-imin+1)*N_states_diag
+
+  !todo: double sz for complex? (done)
+  rc8 = f77_zmq_recv8( zmq_socket_pull, v_t(1,imin), 8_8*sz*2, 0)
+  if(rc8 /= 8*sz*2) stop 'davidson_pull_results_complex failed to pull v_t'
+
+  !todo: double sz for complex? (done)
+  rc8 = f77_zmq_recv8( zmq_socket_pull, s_t(1,imin), 8_8*sz*2, 0)
+  if(rc8 /= 8*sz*2) stop 'davidson_pull_results_complex failed to pull s_t'
+
+! Activate if zmq_socket_pull is a REP
+IRP_IF ZMQ_PUSH
+IRP_ELSE
+  rc = f77_zmq_send( zmq_socket_pull, 'ok', 2, 0)
+  if (rc /= 2) then
+    print *,  irp_here, ' : f77_zmq_send (zmq_socket_pull,...'
+    stop -1
+  endif
+IRP_ENDIF
+
+end subroutine
+
+
+subroutine davidson_collector_complex(zmq_to_qp_run_socket, zmq_socket_pull, v0, s0, sze, N_st)
+  use f77_zmq
+  implicit none
+  BEGIN_DOC
+! Routine collecting the results of the workers in Davidson's algorithm.
+  END_DOC
+
+  integer(ZMQ_PTR), intent(in)   :: zmq_socket_pull
+  integer, intent(in)            :: sze, N_st
+  integer(ZMQ_PTR), intent(in)   :: zmq_to_qp_run_socket
+
+  complex*16      ,intent(inout) :: v0(sze, N_st)
+  complex*16      ,intent(inout) :: s0(sze, N_st)
+
+  integer                          :: more, task_id, imin, imax
+
+  complex*16, allocatable        :: v_t(:,:), s_t(:,:)
+  logical :: sending
+  integer :: i,j
+  integer, external :: zmq_delete_task_async_send
+  integer, external :: zmq_delete_task_async_recv
+
+  allocate(v_t(N_st,N_det), s_t(N_st,N_det))
+  v0 = (0.d0,0.d0)
+  s0 = (0.d0,0.d0)
+  more = 1
+  sending = .False.
+  do while (more == 1)
+    call davidson_pull_results_complex(zmq_socket_pull, v_t, s_t, imin, imax, task_id)
+    if (zmq_delete_task_async_send(zmq_to_qp_run_socket,task_id,sending) == -1) then
+      stop 'davidson: Unable to delete task (send)'
+    endif
+    do j=1,N_st
+      do i=imin,imax
+        v0(i,j) = v0(i,j) + v_t(j,i)
+        s0(i,j) = s0(i,j) + s_t(j,i)
+      enddo
+    enddo
+    if (zmq_delete_task_async_recv(zmq_to_qp_run_socket,more,sending) == -1) then
+      stop 'davidson: Unable to delete task (recv)'
+    endif
+  end do
+  deallocate(v_t,s_t)
+
+end subroutine
+
+
+
+subroutine h_s2_u_0_nstates_zmq_complex(v_0,s_0,u_0,N_st,sze)
+  !todo: maybe make separate zmq_put_psi_complex?
+  !print*,irp_here,' not implemented for complex'
+  !stop -1
+  use omp_lib
+  use bitmasks
+  use f77_zmq
+  implicit none
+  BEGIN_DOC
+  ! Computes $v_0 = H | u_0\rangle$ and $s_0 = S^2  | u_0\rangle$
+  !
+  ! n : number of determinants
+  !
+  ! H_jj : array of $\langle j | H | j \rangle$
+  !
+  ! S2_jj : array of $\langle j | S^2 | j \rangle$
+  END_DOC
+  integer, intent(in)            :: N_st, sze
+  complex*16, intent(out)        :: v_0(sze,N_st), s_0(sze,N_st)
+  complex*16, intent(inout)      :: u_0(sze,N_st)
+  integer                        :: i,j,k
+  integer                        :: ithread
+  complex*16, allocatable        :: u_tc(:,:)
+  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_tc
+  integer(ZMQ_PTR) :: zmq_to_qp_run_socket, zmq_socket_pull
+  PROVIDE psi_det_beta_unique psi_bilinear_matrix_order_transp_reverse psi_det_alpha_unique
+  PROVIDE psi_bilinear_matrix_transp_values_complex psi_bilinear_matrix_values_complex psi_bilinear_matrix_columns_loc
+  PROVIDE ref_bitmask_energy nproc
+  PROVIDE mpi_initialized
+
+  call new_parallel_job(zmq_to_qp_run_socket,zmq_socket_pull,'davidson')
+
+!  integer :: N_states_diag_save
+!  N_states_diag_save = N_states_diag
+!  N_states_diag = N_st
+  if (zmq_put_N_states_diag(zmq_to_qp_run_socket, 1) == -1) then
+    stop 'Unable to put N_states_diag on ZMQ server'
+  endif
+
+  if (zmq_put_psi(zmq_to_qp_run_socket,1) == -1) then
+    stop 'Unable to put psi on ZMQ server'
+  endif
+  energy = 0.d0
+  if (zmq_put_dvector(zmq_to_qp_run_socket,1,'energy',energy,size(energy)) == -1) then
+    stop 'Unable to put energy on ZMQ server'
+  endif
+
+
+  ! Create tasks
+  ! ============
+
+  integer :: istep, imin, imax, ishift, ipos
+  integer, external :: add_task_to_taskserver
+  integer, parameter :: tasksize=10000
+  character*(100000) :: task
+  istep=1
+  ishift=0
+  imin=1
+
+
+  ipos=1
+  do imin=1,N_det,tasksize
+    imax = min(N_det,imin-1+tasksize)
+    do ishift=0,istep-1
+      write(task(ipos:ipos+50),'(4(I11,1X),1X,1A)') imin, imax, ishift, istep, '|'
+      ipos = ipos+50
+      if (ipos > 100000-50) then
+        if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
+          stop 'Unable to add task'
+        endif
+        ipos=1
+      endif
+    enddo
+  enddo
+
+  if (ipos > 1) then
+    if (add_task_to_taskserver(zmq_to_qp_run_socket,trim(task(1:ipos))) == -1) then
+      stop 'Unable to add task'
+    endif
+    ipos=1
+  endif
+
+  allocate(u_tc(N_st,N_det))
+  do k=1,N_st
+    call cdset_order(u_0(1,k),psi_bilinear_matrix_order,N_det)
+  enddo
+
+  call cdtranspose(                                                   &
+      u_0,                                                           &
+      size(u_0, 1),                                                  &
+      u_tc,                                                           &
+      size(u_tc, 1),                                                  &
+      N_det, N_st)
+
+
+  ASSERT (N_st == N_states_diag)
+  ASSERT (sze >= N_det)
+
+  integer :: rc, ni, nj
+  integer*8 :: rc8
+  double precision :: energy(N_st)
+
+  integer, external :: zmq_put_dvector, zmq_put_psi, zmq_put_N_states_diag
+  integer, external :: zmq_put_cdmatrix
+  if (size(u_tc,kind=8) < 8388608_8) then
+    ni = size(u_tc)
+    nj = 1
+  else
+    ni = 8388608
+    nj = int(size(u_tc,kind=8)/8388608_8,4) + 1
+  endif
+  ! Warning : dimensions are modified for efficiency, It is OK since we get the
+  ! full matrix
+  if (zmq_put_cdmatrix(zmq_to_qp_run_socket, 1, 'u_tc', u_tc, ni, nj, size(u_tc,kind=8)) == -1) then
+    stop 'Unable to put u_tc on ZMQ server'
+  endif
+
+  deallocate(u_tc)
+
+  integer, external :: zmq_set_running
+  if (zmq_set_running(zmq_to_qp_run_socket) == -1) then
+    print *,  irp_here, ': Failed in zmq_set_running'
+  endif
+
+  call omp_set_nested(.True.)
+  !$OMP PARALLEL DEFAULT(shared) NUM_THREADS(2) PRIVATE(ithread)
+  ithread = omp_get_thread_num()
+  if (ithread == 0 ) then
+    call davidson_collector_complex(zmq_to_qp_run_socket, zmq_socket_pull, v_0, s_0, N_det, N_st)
+  else
+    call davidson_slave_inproc(1)
+  endif
+  !$OMP END PARALLEL
+  call end_parallel_job(zmq_to_qp_run_socket, zmq_socket_pull, 'davidson')
+
+  !$OMP PARALLEL
+  !$OMP SINGLE
+  do k=1,N_st
+    !$OMP TASK DEFAULT(SHARED) FIRSTPRIVATE(k,N_det)
+    call cdset_order(v_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
+    !$OMP END TASK
+    !$OMP TASK DEFAULT(SHARED) FIRSTPRIVATE(k,N_det)
+    call cdset_order(s_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
+    !$OMP END TASK
+    !$OMP TASK DEFAULT(SHARED) FIRSTPRIVATE(k,N_det)
+    call cdset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
+    !$OMP END TASK
+  enddo
+  !$OMP END SINGLE
+  !$OMP TASKWAIT
+  !$OMP END PARALLEL
+
+!  N_states_diag = N_states_diag_save
+!  SOFT_TOUCH N_states_diag
+end
+

src/davidson/diagonalization_hs2_dressed.irp.f

@@ -33,9 +33,16 @@ BEGIN_PROVIDER [ integer, dressed_column_idx, (N_states) ]
  integer :: i
  double precision :: tmp
  integer, external :: idamax
+ if (is_complex) then
+   do i=1,N_states
+     !todo: check for complex
+     dressed_column_idx(i) = idamax(N_det, cdabs(psi_coef_complex(1,i)), 1)
+   enddo
+ else
  do i=1,N_states
    dressed_column_idx(i) = idamax(N_det, psi_coef(1,i), 1)
  enddo
+ endif
 END_PROVIDER
 
 subroutine davidson_diag_hs2(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_diag,Nint,dressing_state,converged)
@@ -721,7 +728,730 @@ end
 
 
 
+!==============================================================================!
+!                                                                              !
+!                                    Complex                                   !
+!                                                                              !
+!==============================================================================!
+
+subroutine davidson_diag_hs2_complex(dets_in,u_in,s2_out,dim_in,energies,sze,N_st,N_st_diag,Nint,dressing_state,converged)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Davidson diagonalization.
+  !
+  ! dets_in : bitmasks corresponding to determinants
+  !
+  ! u_in : guess coefficients on the various states. Overwritten
+  !   on exit
+  !
+  ! dim_in : leftmost dimension of u_in
+  !
+  ! sze : Number of determinants
+  !
+  ! N_st : Number of eigenstates
+  !
+  ! Initial guess vectors are not necessarily orthonormal
+  END_DOC
+  integer, intent(in)            :: dim_in, sze, N_st, N_st_diag, Nint
+  integer(bit_kind), intent(in)  :: dets_in(Nint,2,sze)
+  complex*16, intent(inout)      :: u_in(dim_in,N_st_diag)
+  double precision, intent(out)  :: energies(N_st_diag), s2_out(N_st_diag)
+  integer, intent(in)            :: dressing_state
+  logical, intent(out)           :: converged
+  double precision, allocatable  :: H_jj(:)
+
+  double precision, external     :: diag_H_mat_elem, diag_S_mat_elem
+  integer                        :: i,k
+  ASSERT (N_st > 0)
+  ASSERT (sze > 0)
+  ASSERT (Nint > 0)
+  ASSERT (Nint == N_int)
+  PROVIDE mo_two_e_integrals_in_map
+  allocate(H_jj(sze))
+
+  H_jj(1) = diag_h_mat_elem(dets_in(1,1,1),Nint)
+  !$OMP PARALLEL DEFAULT(NONE)                                       &
+      !$OMP  SHARED(sze,H_jj, dets_in,Nint)                    &
+      !$OMP  PRIVATE(i)
+  !$OMP DO SCHEDULE(static)
+  do i=2,sze
+    H_jj(i)  = diag_H_mat_elem(dets_in(1,1,i),Nint)
+  enddo
+  !$OMP END DO
+  !$OMP END PARALLEL
+
+  if (dressing_state > 0) then
+    !todo: implement for complex
+    print*,irp_here,' not implemented for complex if dressing_state > 0'
+    stop -1
+    do k=1,N_st
+      do i=1,sze
+        H_jj(i)  += dble(u_in(i,k) * dressing_column_h(i,k))
+      enddo
+    enddo
+  endif
+
+  call davidson_diag_hjj_sjj_complex(dets_in,u_in,H_jj,S2_out,energies,dim_in,sze,N_st,N_st_diag,Nint,dressing_state,converged)
+  deallocate (H_jj)
+end
 
 
+subroutine davidson_diag_hjj_sjj_complex(dets_in,u_in,H_jj,s2_out,energies,dim_in,sze,N_st,N_st_diag_in,Nint,dressing_state,converged)
+  use bitmasks
+  use mmap_module
+  implicit none
+  BEGIN_DOC
+  ! Davidson diagonalization with specific diagonal elements of the H matrix
+  !
+  ! H_jj : specific diagonal H matrix elements to diagonalize de Davidson
+  !
+  ! S2_out : Output : s^2
+  !
+  ! dets_in : bitmasks corresponding to determinants
+  !
+  ! u_in : guess coefficients on the various states. Overwritten
+  !   on exit
+  !
+  ! dim_in : leftmost dimension of u_in
+  !
+  ! sze : Number of determinants
+  !
+  ! N_st : Number of eigenstates
+  !
+  ! N_st_diag_in : Number of states in which H is diagonalized. Assumed > sze
+  !
+  ! Initial guess vectors are not necessarily orthonormal
+  END_DOC
+  integer, intent(in)            :: dim_in, sze, N_st, N_st_diag_in, Nint
+  integer(bit_kind), intent(in)  :: dets_in(Nint,2,sze)
+  double precision,  intent(in)  :: H_jj(sze)
+  integer, intent(in)            :: dressing_state
+  double precision, intent(inout) :: s2_out(N_st_diag_in)
+  complex*16,      intent(inout) :: u_in(dim_in,N_st_diag_in)
+  double precision, intent(out)  :: energies(N_st_diag_in)
+
+  integer                        :: iter, N_st_diag
+  integer                        :: i,j,k,l,m
+  logical, intent(inout)         :: converged
+
+  double precision, external     :: u_dot_u_complex
+  complex*16, external           :: u_dot_v_complex
+
+  integer                        :: k_pairs, kl
+
+  integer                        :: iter2, itertot
+  double precision, allocatable  :: lambda(:), s2(:)
+  complex*16, allocatable  :: y(:,:), h(:,:), h_p(:,:)
+  complex*8, allocatable              :: y_s(:,:)
+  complex*16, allocatable  :: s_(:,:), s_tmp(:,:)
+  double precision               :: diag_h_mat_elem
+  double precision, allocatable  :: residual_norm(:)
+  character*(16384)              :: write_buffer
+  double precision               :: to_print(3,N_st)
+  double precision               :: cpu, wall
+  integer                        :: shift, shift2, itermax, istate
+  double precision               :: r1, r2, alpha
+  logical                        :: state_ok(N_st_diag_in*davidson_sze_max)
+  integer                        :: nproc_target
+  integer                        :: order(N_st_diag_in)
+  double precision               :: cmax
+  double precision, allocatable  :: overlap(:,:)
+  complex*16, allocatable  :: y_tmp(:,:)
+  complex*16, allocatable  :: S_d(:,:)
+  complex*16, allocatable  :: U(:,:)
+  complex*16, pointer      :: W(:,:)
+  complex*8, pointer                  :: S(:,:)
+  logical                        :: disk_based
+  double precision               :: energy_shift(N_st_diag_in*davidson_sze_max)
+
+  include 'constants.include.F'
+
+  N_st_diag = N_st_diag_in
+  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, W, S, y, y_s, S_d, h, lambda
+  if (N_st_diag*3 > sze) then
+    print *,  'error in Davidson :'
+    print *,  'Increase n_det_max_full to ', N_st_diag*3
+    stop -1
+  endif
+
+  itermax = max(2,min(davidson_sze_max, sze/N_st_diag))+1
+  itertot = 0
+
+  if (state_following) then
+    allocate(overlap(N_st_diag*itermax, N_st_diag*itermax), &
+             y_tmp(N_st_diag*itermax, N_st_diag*itermax))
+  else
+    allocate(overlap(1,1),y_tmp(1,1))  ! avoid 'if' for deallocate
+  endif
+  overlap = 0.d0
+  y_tmp = (0.d0,0.d0)
+
+  !todo: provide psi_bilinear_matrix_values? (unlinked now)
+  PROVIDE nuclear_repulsion expected_s2 psi_bilinear_matrix_order psi_bilinear_matrix_order_reverse threshold_davidson_pt2
+
+  call write_time(6)
+  write(6,'(A)') ''
+  write(6,'(A)') 'Davidson Diagonalization'
+  write(6,'(A)') '------------------------'
+  write(6,'(A)') ''
+
+  ! Find max number of cores to fit in memory
+  ! -----------------------------------------
+
+  nproc_target = nproc
+  double precision :: rss
+  integer :: maxab
+  maxab = max(N_det_alpha_unique, N_det_beta_unique)+1
+
+  m=1
+  disk_based = .False.
+  call resident_memory(rss)
+  do
+    !r1 = 8.d0 *                                   &! bytes
+    !     ( dble(sze)*(N_st_diag*itermax)          &! U
+    !     + 1.5d0*dble(sze*m)*(N_st_diag*itermax)  &! W,S
+    !     + 1.d0*dble(sze)*(N_st_diag)             &! S_d
+    !     + 4.5d0*(N_st_diag*itermax)**2           &! h,y,y_s,s_,s_tmp
+    !     + 2.d0*(N_st_diag*itermax)               &! s2,lambda
+    !     + 1.d0*(N_st_diag)                       &! residual_norm
+    !                                               ! In H_S2_u_0_nstates_zmq
+    !     + 3.d0*(N_st_diag*N_det)                 &! u_t, v_t, s_t on collector
+    !     + 3.d0*(N_st_diag*N_det)                 &! u_t, v_t, s_t on slave
+    !     + 0.5d0*maxab                            &! idx0 in H_S2_u_0_nstates_openmp_work_*
+    !     + nproc_target *                         &! In OMP section
+    !       ( 1.d0*(N_int*maxab)                   &! buffer
+    !       + 3.5d0*(maxab) )                      &! singles_a, singles_b, doubles, idx
+    !     ) / 1024.d0**3
+    r1 = 8.d0 *                                   &! bytes
+         ( 2*dble(sze)*(N_st_diag*itermax)          &! U
+         + 2*1.5d0*dble(sze*m)*(N_st_diag*itermax)  &! W,S
+         + 2*1.d0*dble(sze)*(N_st_diag)             &! S_d
+         + 2*4.5d0*(N_st_diag*itermax)**2           &! h,y,y_s,s_,s_tmp
+         + 2.d0*(N_st_diag*itermax)               &! s2,lambda
+         + 1.d0*(N_st_diag)                       &! residual_norm
+                                                   ! In H_S2_u_0_nstates_zmq
+         + 2*3.d0*(N_st_diag*N_det)                 &! u_t, v_t, s_t on collector
+         + 2*3.d0*(N_st_diag*N_det)                 &! u_t, v_t, s_t on slave
+         + 0.5d0*maxab                            &! idx0 in H_S2_u_0_nstates_openmp_work_*
+         + nproc_target *                         &! In OMP section
+           ( 1.d0*(N_int*maxab)                   &! buffer
+           + 3.5d0*(maxab) )                      &! singles_a, singles_b, doubles, idx
+         ) / 1024.d0**3
+
+    if (nproc_target == 0) then
+      call check_mem(r1,irp_here)
+      nproc_target = 1
+      exit
+    endif
+
+    if (r1+rss < qp_max_mem) then
+      exit
+    endif
+
+    if (itermax > 4) then
+      itermax = itermax - 1
+    else if (m==1.and.disk_based_davidson) then
+      m=0
+      disk_based = .True.
+      itermax = 6
+    else
+      nproc_target = nproc_target - 1
+    endif
+
+  enddo
+  nthreads_davidson = nproc_target
+  TOUCH nthreads_davidson
+  call write_int(6,N_st,'Number of states')
+  call write_int(6,N_st_diag,'Number of states in diagonalization')
+  call write_int(6,sze,'Number of determinants')
+  call write_int(6,nproc_target,'Number of threads for diagonalization')
+  call write_double(6, r1, 'Memory(Gb)')
+  if (disk_based) then
+    print *, 'Using swap space to reduce RAM'
+  endif
+
+  !---------------
+
+  write(6,'(A)') ''
+  write_buffer = '====='
+  do i=1,N_st
+    write_buffer = trim(write_buffer)//' ================ =========== ==========='
+  enddo
+  write(6,'(A)') write_buffer(1:6+41*N_st)
+  write_buffer = 'Iter'
+  do i=1,N_st
+    write_buffer = trim(write_buffer)//'       Energy          S^2       Residual '
+  enddo
+  write(6,'(A)') write_buffer(1:6+41*N_st)
+  write_buffer = '====='
+  do i=1,N_st
+    write_buffer = trim(write_buffer)//' ================ =========== ==========='
+  enddo
+  write(6,'(A)') write_buffer(1:6+41*N_st)
+
+  !todo: already resized, but do we need to change c_f_pointer for complex?
+  if (disk_based) then
+    ! Create memory-mapped files for W and S
+    type(c_ptr) :: ptr_w, ptr_s
+    integer :: fd_s, fd_w
+    call mmap(trim(ezfio_work_dir)//'davidson_w', (/int(sze,8),int(N_st_diag*itermax,8)/),&
+        8*2, fd_w, .False., ptr_w)
+    call mmap(trim(ezfio_work_dir)//'davidson_s', (/int(sze,8),int(N_st_diag*itermax,8)/),&
+        4*2, fd_s, .False., ptr_s)
+    call c_f_pointer(ptr_w, w, (/sze,N_st_diag*itermax/))
+    call c_f_pointer(ptr_s, s, (/sze,N_st_diag*itermax/))
+  else
+    allocate(W(sze,N_st_diag*itermax), S(sze,N_st_diag*itermax))
+  endif
+
+  allocate(                                                          &
+      ! Large
+      U(sze,N_st_diag*itermax),                                      &
+      S_d(sze,N_st_diag),                                            &
+
+      ! Small
+      h(N_st_diag*itermax,N_st_diag*itermax),                        &
+      h_p(N_st_diag*itermax,N_st_diag*itermax),                      &
+      y(N_st_diag*itermax,N_st_diag*itermax),                        &
+      s_(N_st_diag*itermax,N_st_diag*itermax),                       &
+      s_tmp(N_st_diag*itermax,N_st_diag*itermax),                    &
+      residual_norm(N_st_diag),                                      &
+      s2(N_st_diag*itermax),                                         &
+      y_s(N_st_diag*itermax,N_st_diag*itermax),                      &
+      lambda(N_st_diag*itermax))
+
+  h = (0.d0,0.d0)
+  U = (0.d0,0.d0)
+  y = (0.d0,0.d0)
+  s_ = (0.d0,0.d0)
+  s_tmp = (0.d0,0.d0)
+
+
+  ASSERT (N_st > 0)
+  ASSERT (N_st_diag >= N_st)
+  ASSERT (sze > 0)
+  ASSERT (Nint > 0)
+  ASSERT (Nint == N_int)
+
+  ! Davidson iterations
+  ! ===================
+
+  converged = .False.
+
+  do k=N_st+1,N_st_diag
+    u_in(k,k) = (10.d0,0.d0)
+    do i=1,sze
+      call random_number(r1)
+      call random_number(r2)
+      r1 = dsqrt(-2.d0*dlog(r1))
+      r2 = dtwo_pi*r2
+      !todo: real or complex? rescale for complex? sqrt(2)?
+      u_in(i,k) = dcmplx(r1*dcos(r2),0.d0)
+      !u_in(i,k) = dcmplx(r1*dcos(r2),r1*dsin(r2))
+    enddo
+  enddo
+  do k=1,N_st_diag
+    call normalize_complex(u_in(1,k),sze)
+  enddo
+
+  do k=1,N_st_diag
+    do i=1,sze
+      U(i,k) = u_in(i,k)
+    enddo
+  enddo
+
+
+  do while (.not.converged)
+    itertot = itertot+1
+    if (itertot == 8) then
+      exit
+    endif
+
+    do iter=1,itermax-1
+
+      shift  = N_st_diag*(iter-1)
+      shift2 = N_st_diag*iter
+
+      if ((iter > 1).or.(itertot == 1)) then
+        ! Compute |W_k> = \sum_i |i><i|H|u_k>
+        ! -----------------------------------
+
+        if (disk_based) then
+          call ortho_qr_unblocked_complex(U,size(U,1),sze,shift2)
+          call ortho_qr_unblocked_complex(U,size(U,1),sze,shift2)
+        else
+          call ortho_qr_complex(U,size(U,1),sze,shift2)
+          call ortho_qr_complex(U,size(U,1),sze,shift2)
+        endif
+
+        ! |W> = H|U>
+        ! |S_d> = S^2|U>
+        if ((sze > 100000).and.distributed_davidson) then
+            call h_s2_u_0_nstates_zmq_complex(W(1,shift+1),S_d,U(1,shift+1),N_st_diag,sze)
+        else
+            call h_s2_u_0_nstates_openmp_complex(W(1,shift+1),S_d,U(1,shift+1),N_st_diag,sze)
+        endif
+        S(1:sze,shift+1:shift+N_st_diag) = cmplx(S_d(1:sze,1:N_st_diag))
+      else
+         ! Already computed in update below
+         continue
+      endif
+
+      if (dressing_state > 0) then
+        !todo: implement for complex
+        print*,irp_here,' not implemented for complex (dressed)'
+        stop -1
+!
+!        if (N_st == 1) then
+!
+!          l = dressed_column_idx(1)
+!          complex*16 :: f
+!          !todo: check for complex
+!          f = (1.0d0,0.d0)/psi_coef(l,1)
+!          do istate=1,N_st_diag
+!            do i=1,sze
+!              !todo: conjugate?
+!              W(i,shift+istate) += dressing_column_h_complex(i,1) *f * U(l,shift+istate)
+!              W(l,shift+istate) += dressing_column_h_complex(i,1) *f * U(i,shift+istate)
+!              S(i,shift+istate) += cmplx(dressing_column_s_complex(i,1) *f * U(l,shift+istate))
+!              S(l,shift+istate) += cmplx(dressing_column_s_complex(i,1) *f * U(i,shift+istate))
+!            enddo
+!
+!          enddo
+!
+!        else
+!
+!          call dgemm('T','N', N_st, N_st_diag, sze, 1.d0, &
+!            psi_coef, size(psi_coef,1), &
+!            U(1,shift+1), size(U,1), 0.d0, s_tmp, size(s_tmp,1))
+!
+!          call dgemm('N','N', sze, N_st_diag, N_st, 1.0d0, &
+!            dressing_column_h, size(dressing_column_h,1), s_tmp, size(s_tmp,1), &
+!            1.d0, W(1,shift+1), size(W,1))
+!
+!          call dgemm('N','N', sze, N_st_diag, N_st, 1.0d0, &
+!            dressing_column_s, size(dressing_column_s,1), s_tmp, size(s_tmp,1), &
+!            1.d0, S_d, size(S_d,1))
+!
+!
+!          call dgemm('T','N', N_st, N_st_diag, sze, 1.d0, &
+!            dressing_column_h, size(dressing_column_h,1), &
+!            U(1,shift+1), size(U,1), 0.d0, s_tmp, size(s_tmp,1))
+!
+!          call dgemm('N','N', sze, N_st_diag, N_st, 1.0d0, &
+!            psi_coef, size(psi_coef,1), s_tmp, size(s_tmp,1), &
+!            1.d0, W(1,shift+1), size(W,1))
+!
+!          call dgemm('T','N', N_st, N_st_diag, sze, 1.d0, &
+!            dressing_column_s, size(dressing_column_s,1), &
+!            U(1,shift+1), size(U,1), 0.d0, s_tmp, size(s_tmp,1))
+!
+!          call dgemm('N','N', sze, N_st_diag, N_st, 1.0d0, &
+!            psi_coef, size(psi_coef,1), s_tmp, size(s_tmp,1), &
+!            1.d0, S_d, size(S_d,1))
+!
+!        endif
+      endif
+
+      ! Compute s_kl = <u_k | S_l> = <u_k| S2 |u_l>
+      ! -------------------------------------------
+
+       !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,j,k) COLLAPSE(2)
+       do j=1,shift2
+         do i=1,shift2
+           s_(i,j) = (0.d0,0.d0)
+           do k=1,sze
+             s_(i,j) = s_(i,j) + dconjg(U(k,i)) * cmplx(S(k,j))
+           enddo
+          enddo
+        enddo
+        !$OMP END PARALLEL DO
+
+      ! Compute h_kl = <u_k | W_l> = <u_k| H |u_l>
+      ! -------------------------------------------
+
+      !todo: why not size(h,1)?
+      call zgemm('C','N', shift2, shift2, sze,                       &
+          (1.d0,0.d0), U, size(U,1), W, size(W,1),                   &
+          (0.d0,0.d0), h, size(h_p,1))
+
+      ! Penalty method
+      ! --------------
+
+      if (s2_eig) then
+        h_p = s_
+        do k=1,shift2
+          h_p(k,k) = h_p(k,k) + (S_z2_Sz - expected_s2)
+        enddo
+        if (only_expected_s2) then
+          alpha = 0.1d0
+          h_p = h + alpha*h_p
+        else
+          alpha = 0.0001d0
+          h_p = h + alpha*h_p
+        endif
+      else
+        h_p = h
+        alpha = 0.d0
+      endif
+
+      ! Diagonalize h_p
+      ! ---------------
+
+      call lapack_diag_complex(lambda,y,h_p,size(h_p,1),shift2)
+
+      ! Compute Energy for each eigenvector
+      ! -----------------------------------
+
+      call zgemm('N','N',shift2,shift2,shift2,                       &
+          (1.d0,0.d0), h, size(h,1), y, size(y,1),                   &
+          (0.d0,0.d0), s_tmp, size(s_tmp,1))
+
+      call zgemm('C','N',shift2,shift2,shift2,                       &
+          (1.d0,0.d0), y, size(y,1), s_tmp, size(s_tmp,1),           &
+          (0.d0,0.d0), h, size(h,1))
+
+      do k=1,shift2
+        lambda(k) = dble(h(k,k))
+      enddo
+
+      ! Compute S2 for each eigenvector
+      ! -------------------------------
+
+      call zgemm('N','N',shift2,shift2,shift2,                       &
+          (1.d0,0.d0), s_, size(s_,1), y, size(y,1),                 &
+          (0.d0,0.d0), s_tmp, size(s_tmp,1))
+
+      call zgemm('C','N',shift2,shift2,shift2,                       &
+          (1.d0,0.d0), y, size(y,1), s_tmp, size(s_tmp,1),           &
+          (0.d0,0.d0), s_, size(s_,1))
+
+      do k=1,shift2
+        s2(k) = dble(s_(k,k)) + S_z2_Sz
+      enddo
+
+      if (only_expected_s2) then
+          do k=1,shift2
+            state_ok(k) = (dabs(s2(k)-expected_s2) < 0.6d0)
+          enddo
+      else
+        do k=1,size(state_ok)
+          state_ok(k) = .True.
+        enddo
+      endif
+
+      do k=1,shift2
+        if (.not. state_ok(k)) then
+          do l=k+1,shift2
+            if (state_ok(l)) then
+              call zswap(shift2, y(1,k), 1, y(1,l), 1)
+              call dswap(1, s2(k), 1, s2(l), 1)
+              call dswap(1, lambda(k), 1, lambda(l), 1)
+              state_ok(k) = .True.
+              state_ok(l) = .False.
+              exit
+            endif
+          enddo
+        endif
+      enddo
+
+      if (state_following) then
+
+        overlap = -1.d0
+        do k=1,shift2
+          do i=1,shift2
+            overlap(k,i) = cdabs(y(k,i))
+          enddo
+        enddo
+        do k=1,N_st
+          cmax = -1.d0
+          do i=1,N_st
+            if (overlap(i,k) > cmax) then
+              cmax = overlap(i,k)
+              order(k) = i
+            endif
+          enddo
+          do i=1,N_st_diag
+            overlap(order(k),i) = -1.d0
+          enddo
+        enddo
+        y_tmp = y
+        do k=1,N_st
+          l = order(k)
+          if (k /= l) then
+            y(1:shift2,k) = y_tmp(1:shift2,l)
+          endif
+        enddo
+        do k=1,N_st
+          overlap(k,1) = lambda(k)
+          overlap(k,2) = s2(k)
+        enddo
+        do k=1,N_st
+          l = order(k)
+          if (k /= l) then
+            lambda(k) = overlap(l,1)
+            s2(k) = overlap(l,2)
+          endif
+        enddo
+
+      endif
+
+
+      ! Express eigenvectors of h in the determinant basis
+      ! --------------------------------------------------
+      !todo: check for complex
+      call zgemm('N','N', sze, N_st_diag, shift2,                    &
+          (1.d0,0.d0), U, size(U,1), y, size(y,1), (0.d0,0.d0), U(1,shift2+1), size(U,1))
+      call zgemm('N','N', sze, N_st_diag, shift2,                    &
+          (1.d0,0.d0), W, size(W,1), y, size(y,1), (0.d0,0.d0), W(1,shift2+1), size(W,1))
+
+      y_s(:,:) = cmplx(y(:,:))
+      call cgemm('N','N', sze, N_st_diag, shift2,                    &
+          (1.e0,0.e0), S, size(S,1), y_s, size(y_s,1), (0.e0,0.e0), S(1,shift2+1), size(S,1))
+
+      ! Compute residual vector and davidson step
+      ! -----------------------------------------
+
+      !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(i,k)
+      do k=1,N_st_diag
+        do i=1,sze
+          U(i,shift2+k) =  &
+            (lambda(k) * U(i,shift2+k) - W(i,shift2+k) )      &
+              /max(H_jj(i) - lambda (k),1.d-2)
+        enddo
+
+        if (k <= N_st) then
+          residual_norm(k) = u_dot_u_complex(U(1,shift2+k),sze)
+          to_print(1,k) = lambda(k) + nuclear_repulsion
+          to_print(2,k) = s2(k)
+          to_print(3,k) = residual_norm(k)
+        endif
+      enddo
+      !$OMP END PARALLEL DO
+
+
+      if ((itertot>1).and.(iter == 1)) then
+        !don't print 
+        continue
+      else
+        write(*,'(1X,I3,1X,100(1X,F16.10,1X,F11.6,1X,E11.3))') iter-1, to_print(1:3,1:N_st)
+      endif
+
+      ! Check convergence
+      if (iter > 1) then
+          converged = dabs(maxval(residual_norm(1:N_st))) < threshold_davidson_pt2
+      endif   
+      
+
+      do k=1,N_st
+        if (residual_norm(k) > 1.e8) then
+          print *, 'Davidson failed'
+          stop -1
+        endif
+      enddo
+      if (converged) then
+        exit
+      endif
+
+      logical, external :: qp_stop
+      if (qp_stop()) then
+        converged = .True.
+        exit
+      endif
+
+
+    enddo
+
+    ! Re-contract U and update S and W
+    ! --------------------------------
+
+    call cgemm('N','N', sze, N_st_diag, shift2, (1.e0,0.e0),      &
+        S, size(S,1), y_s, size(y_s,1), (0.e0,0.e0), S(1,shift2+1), size(S,1))
+    do k=1,N_st_diag
+      do i=1,sze
+        S(i,k) = S(i,shift2+k)
+      enddo
+    enddo
+
+    call zgemm('N','N', sze, N_st_diag, shift2, (1.d0,0.d0),      &
+        W, size(W,1), y, size(y,1), (0.d0,0.d0), u_in, size(u_in,1))
+    do k=1,N_st_diag
+      do i=1,sze
+        W(i,k) = u_in(i,k)
+      enddo
+    enddo
+
+    call zgemm('N','N', sze, N_st_diag, shift2, (1.d0,0.d0),      &
+        U, size(U,1), y, size(y,1), (0.d0,0.d0), u_in, size(u_in,1))
+    do k=1,N_st_diag
+      do i=1,sze
+        U(i,k) = u_in(i,k)
+      enddo
+    enddo
+    if (disk_based) then
+      call ortho_qr_unblocked_complex(U,size(U,1),sze,N_st_diag)
+      call ortho_qr_unblocked_complex(U,size(U,1),sze,N_st_diag)
+    else
+      call ortho_qr_complex(U,size(U,1),sze,N_st_diag)
+      call ortho_qr_complex(U,size(U,1),sze,N_st_diag)
+    endif
+    do j=1,N_st_diag
+      k=1
+      do while ((k<sze).and.(U(k,j) == (0.d0,0.d0)))
+        k = k+1
+      enddo
+      !if (U(k,j) * u_in(k,j) < 0.d0) then
+      !todo: complex! maybe change criterion here?
+      ! if U is close to u_in, then arg(conjg(U)*u_in) will be near zero
+      if (dble(dconjg(U(k,j)) * u_in(k,j)) < 0.d0) then
+        do i=1,sze
+          W(i,j) = -W(i,j)
+          S(i,j) = -S(i,j)
+        enddo
+      endif
+    enddo
+    do j=1,N_st_diag
+      do i=1,sze
+        S_d(i,j) = cmplx(S(i,j))
+      enddo
+    enddo
+
+  enddo
+
+  do k=1,N_st_diag
+    energies(k) = lambda(k)
+    s2_out(k) = s2(k)
+  enddo
+  write_buffer = '======'
+  do i=1,N_st
+    write_buffer = trim(write_buffer)//' ================ =========== ==========='
+  enddo
+  write(6,'(A)') trim(write_buffer)
+  write(6,'(A)') ''
+  call write_time(6)
+
+  if (disk_based)then
+    ! Remove temp files
+    integer, external :: getUnitAndOpen
+    call munmap( (/int(sze,8),int(N_st_diag*itermax,8)/), 2*8, fd_w, ptr_w )
+    fd_w = getUnitAndOpen(trim(ezfio_work_dir)//'davidson_w','r')
+    close(fd_w,status='delete')
+    call munmap( (/int(sze,8),int(N_st_diag*itermax,8)/), 2*4, fd_s, ptr_s )
+    fd_s = getUnitAndOpen(trim(ezfio_work_dir)//'davidson_s','r')
+    close(fd_s,status='delete')
+  else
+    deallocate(W,S)
+  endif
+
+  deallocate (                                                       &
+      residual_norm,                                                 &
+      U, overlap, y_tmp,                                             &
+      h, y_s, S_d,                                                   &
+      y, s_, s_tmp,                                                  &
+      lambda                                                         &
+      )
+  FREE nthreads_davidson
+end
 
 

src/davidson/diagonalize_ci.irp.f

@@ -20,8 +20,21 @@ BEGIN_PROVIDER [ double precision, CI_energy, (N_states_diag) ]
 END_PROVIDER
 
  BEGIN_PROVIDER [ double precision, CI_electronic_energy, (N_states_diag) ]
-&BEGIN_PROVIDER [ double precision, CI_eigenvectors, (N_det,N_states_diag) ]
 &BEGIN_PROVIDER [ double precision, CI_s2, (N_states_diag) ]
+  implicit none
+  if (is_complex) then
+    ci_s2(1:N_states_diag) = ci_s2_complex(1:N_states_diag)
+    ci_electronic_energy(1:N_states_diag) = ci_electronic_energy_complex(1:N_states_diag)
+  else
+    ci_s2(1:N_states_diag) = ci_s2_real(1:N_states_diag)
+    ci_electronic_energy(1:N_states_diag) = ci_electronic_energy_real(1:N_states_diag)
+  endif
+END_PROVIDER
+
+
+ BEGIN_PROVIDER [ double precision, CI_electronic_energy_real, (N_states_diag) ]
+&BEGIN_PROVIDER [ double precision, CI_eigenvectors, (N_det,N_states_diag) ]
+&BEGIN_PROVIDER [ double precision, CI_s2_real, (N_states_diag) ]
    BEGIN_DOC
    ! Eigenvectors/values of the |CI| matrix
    END_DOC
@@ -57,8 +70,8 @@ END_PROVIDER
 
    if (diag_algorithm == "Davidson") then
 
-     call davidson_diag_HS2(psi_det,CI_eigenvectors, CI_s2, &
-         size(CI_eigenvectors,1),CI_electronic_energy,               &
+     call davidson_diag_HS2(psi_det,CI_eigenvectors, CI_s2_real, &
+         size(CI_eigenvectors,1),CI_electronic_energy_real,               &
          N_det,min(N_det,N_states),min(N_det,N_states_diag),N_int,0,converged)
 
      integer :: N_states_diag_save
@@ -75,17 +88,17 @@ END_PROVIDER
         allocate (CI_eigenvectors_tmp (N_det,N_states_diag) )
         allocate (CI_s2_tmp (N_states_diag) )
 
-        CI_electronic_energy_tmp(1:N_states_diag_save) = CI_electronic_energy(1:N_states_diag_save)
+        CI_electronic_energy_tmp(1:N_states_diag_save) = CI_electronic_energy_real(1:N_states_diag_save)
         CI_eigenvectors_tmp(1:N_det,1:N_states_diag_save) = CI_eigenvectors(1:N_det,1:N_states_diag_save)
-        CI_s2_tmp(1:N_states_diag_save) = CI_s2(1:N_states_diag_save)
+        CI_s2_tmp(1:N_states_diag_save) = CI_s2_real(1:N_states_diag_save)
 
         call davidson_diag_HS2(psi_det,CI_eigenvectors_tmp, CI_s2_tmp, &
             size(CI_eigenvectors_tmp,1),CI_electronic_energy_tmp,               &
             N_det,min(N_det,N_states),min(N_det,N_states_diag),N_int,0,converged)
 
-        CI_electronic_energy(1:N_states_diag_save) = CI_electronic_energy_tmp(1:N_states_diag_save)
+        CI_electronic_energy_real(1:N_states_diag_save) = CI_electronic_energy_tmp(1:N_states_diag_save)
         CI_eigenvectors(1:N_det,1:N_states_diag_save) = CI_eigenvectors_tmp(1:N_det,1:N_states_diag_save)
-        CI_s2(1:N_states_diag_save) = CI_s2_tmp(1:N_states_diag_save)
+        CI_s2_real(1:N_states_diag_save) = CI_s2_tmp(1:N_states_diag_save)
 
         deallocate (CI_electronic_energy_tmp)
         deallocate (CI_eigenvectors_tmp)
@@ -110,7 +123,7 @@ END_PROVIDER
          H_prime(j,j) = H_prime(j,j) + alpha*(S_z2_Sz - expected_s2)
        enddo
        call lapack_diag(eigenvalues,eigenvectors,H_prime,size(H_prime,1),N_det)
-       CI_electronic_energy(:) = 0.d0
+       CI_electronic_energy_real(:) = 0.d0
        i_state = 0
        allocate (s2_eigvalues(N_det))
        allocate(index_good_state_array(N_det),good_state_array(N_det))
@@ -141,8 +154,8 @@ END_PROVIDER
            do i=1,N_det
              CI_eigenvectors(i,j) = eigenvectors(i,index_good_state_array(j))
            enddo
-           CI_electronic_energy(j) = eigenvalues(index_good_state_array(j))
-           CI_s2(j) = s2_eigvalues(index_good_state_array(j))
+           CI_electronic_energy_real(j) = eigenvalues(index_good_state_array(j))
+           CI_s2_real(j) = s2_eigvalues(index_good_state_array(j))
          enddo
          i_other_state = 0
          do j = 1, N_det
@@ -154,8 +167,8 @@ END_PROVIDER
            do i=1,N_det
              CI_eigenvectors(i,i_state+i_other_state) = eigenvectors(i,j)
            enddo
-           CI_electronic_energy(i_state+i_other_state) = eigenvalues(j)
-           CI_s2(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state)
+           CI_electronic_energy_real(i_state+i_other_state) = eigenvalues(j)
+           CI_s2_real(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state)
          enddo
 
        else
@@ -172,8 +185,8 @@ END_PROVIDER
            do i=1,N_det
              CI_eigenvectors(i,j) = eigenvectors(i,j)
            enddo
-           CI_electronic_energy(j) = eigenvalues(j)
-           CI_s2(j) = s2_eigvalues(j)
+           CI_electronic_energy_real(j) = eigenvalues(j)
+           CI_s2_real(j) = s2_eigvalues(j)
          enddo
        endif
        deallocate(index_good_state_array,good_state_array)
@@ -181,22 +194,22 @@ END_PROVIDER
      else
        call lapack_diag(eigenvalues,eigenvectors,                      &
            H_matrix_all_dets,size(H_matrix_all_dets,1),N_det)
-       CI_electronic_energy(:) = 0.d0
-       call u_0_S2_u_0(CI_s2,eigenvectors,N_det,psi_det,N_int,&
+       CI_electronic_energy_real(:) = 0.d0
+       call u_0_S2_u_0(CI_s2_real,eigenvectors,N_det,psi_det,N_int,&
           min(N_det,N_states_diag),size(eigenvectors,1))
        ! Select the "N_states_diag" states of lowest energy
        do j=1,min(N_det,N_states_diag)
          do i=1,N_det
            CI_eigenvectors(i,j) = eigenvectors(i,j)
          enddo
-         CI_electronic_energy(j) = eigenvalues(j)
+         CI_electronic_energy_real(j) = eigenvalues(j)
        enddo
      endif
      do k=1,N_states_diag
-       CI_electronic_energy(k) = 0.d0
+       CI_electronic_energy_real(k) = 0.d0
        do j=1,N_det
          do i=1,N_det
-           CI_electronic_energy(k) +=                                &
+           CI_electronic_energy_real(k) +=                                &
                CI_eigenvectors(i,k) * CI_eigenvectors(j,k) *         &
                H_matrix_all_dets(i,j)
          enddo
@@ -207,6 +220,215 @@ END_PROVIDER
 
 END_PROVIDER
 
+ BEGIN_PROVIDER [ double precision, CI_electronic_energy_complex, (N_states_diag) ]
+&BEGIN_PROVIDER [ complex*16, CI_eigenvectors_complex, (N_det,N_states_diag) ]
+&BEGIN_PROVIDER [ double precision, CI_s2_complex, (N_states_diag) ]
+   BEGIN_DOC
+   ! Eigenvectors/values of the |CI| matrix
+   END_DOC
+   implicit none
+   double precision               :: ovrlp
+   complex*16                     :: u_dot_v_complex
+   integer                        :: i_good_state
+   integer, allocatable           :: index_good_state_array(:)
+   logical, allocatable           :: good_state_array(:)
+   double precision, allocatable  :: s2_values_tmp(:)
+   integer                        :: i_other_state
+   double precision, allocatable  :: eigenvalues(:)
+   complex*16, allocatable        :: eigenvectors(:,:), H_prime(:,:)
+   integer                        :: i_state
+   double precision               :: e_0
+   integer                        :: i,j,k
+   double precision, allocatable  :: s2_eigvalues(:)
+   double precision, allocatable  :: e_array(:)
+   integer, allocatable           :: iorder(:)
+   logical                        :: converged
+
+   PROVIDE threshold_davidson nthreads_davidson
+   ! Guess values for the "N_states" states of the |CI| eigenvectors
+   do j=1,min(N_states,N_det)
+     do i=1,N_det
+       ci_eigenvectors_complex(i,j) = psi_coef_complex(i,j)
+     enddo
+   enddo
+
+   do j=min(N_states,N_det)+1,N_states_diag
+     do i=1,N_det
+       ci_eigenvectors_complex(i,j) = (0.d0,0.d0)
+     enddo
+   enddo
+
+   if (diag_algorithm == "Davidson") then
+
+     call davidson_diag_hs2_complex(psi_det,ci_eigenvectors_complex, ci_s2_complex, &
+         size(ci_eigenvectors_complex,1),ci_electronic_energy_complex,               &
+         N_det,min(N_det,N_states),min(N_det,N_states_diag),N_int,0,converged)
+
+     integer :: N_states_diag_save
+     N_states_diag_save = N_states_diag
+     do while (.not.converged)
+        double precision, allocatable :: ci_electronic_energy_tmp (:)
+        complex*16, allocatable :: ci_eigenvectors_tmp (:,:)
+        double precision, allocatable :: ci_s2_tmp (:)
+
+        N_states_diag  *= 2
+        TOUCH N_states_diag
+
+        allocate (ci_electronic_energy_tmp (N_states_diag) )
+        allocate (ci_eigenvectors_tmp (N_det,N_states_diag) )
+        allocate (ci_s2_tmp (N_states_diag) )
+
+        ci_electronic_energy_tmp(1:N_states_diag_save) = ci_electronic_energy_complex(1:N_states_diag_save)
+        ci_eigenvectors_tmp(1:N_det,1:N_states_diag_save) = ci_eigenvectors_complex(1:N_det,1:N_states_diag_save)
+        ci_s2_tmp(1:N_states_diag_save) = ci_s2_complex(1:N_states_diag_save)
+
+        call davidson_diag_hs2_complex(psi_det,ci_eigenvectors_tmp, ci_s2_tmp, &
+            size(ci_eigenvectors_tmp,1),ci_electronic_energy_tmp,               &
+            N_det,min(N_det,N_states),min(N_det,N_states_diag),N_int,0,converged)
+
+        ci_electronic_energy_complex(1:N_states_diag_save) = ci_electronic_energy_tmp(1:N_states_diag_save)
+        ci_eigenvectors_complex(1:N_det,1:N_states_diag_save) = ci_eigenvectors_tmp(1:N_det,1:N_states_diag_save)
+        ci_s2_complex(1:N_states_diag_save) = ci_s2_tmp(1:N_states_diag_save)
+
+        deallocate (ci_electronic_energy_tmp)
+        deallocate (ci_eigenvectors_tmp)
+        deallocate (ci_s2_tmp)
+     enddo
+     if (N_states_diag > N_states_diag_save) then
+       N_states_diag = N_states_diag_save
+       TOUCH N_states_diag
+     endif
+
+   else if (diag_algorithm == "Lapack") then
+
+     print *,  'Diagonalization of H using Lapack'
+     allocate (eigenvectors(size(h_matrix_all_dets_complex,1),N_det))
+     allocate (eigenvalues(N_det))
+     if (s2_eig) then
+       double precision, parameter :: alpha = 0.1d0
+       allocate (H_prime(N_det,N_det) )
+       H_prime(1:N_det,1:N_det) = h_matrix_all_dets_complex(1:N_det,1:N_det) +  &
+         alpha * s2_matrix_all_dets(1:N_det,1:N_det)
+       do j=1,N_det
+         H_prime(j,j) = H_prime(j,j) + alpha*(s_z2_sz - expected_s2)
+       enddo
+       call lapack_diag_complex(eigenvalues,eigenvectors,H_prime,size(H_prime,1),N_det)
+       ci_electronic_energy_complex(:) = (0.d0,0.d0)
+       i_state = 0
+       allocate (s2_eigvalues(N_det))
+       allocate(index_good_state_array(N_det),good_state_array(N_det))
+       good_state_array = .False.
+       call u_0_s2_u_0_complex(s2_eigvalues,eigenvectors,N_det,psi_det,N_int,&
+         N_det,size(eigenvectors,1))
+       if (only_expected_s2) then
+          do j=1,N_det
+            ! Select at least n_states states with S^2 values closed to "expected_s2"
+            if(dabs(s2_eigvalues(j)-expected_s2).le.0.5d0)then
+              i_state +=1
+              index_good_state_array(i_state) = j
+              good_state_array(j) = .True.
+            endif
+            if(i_state.eq.N_states) then
+              exit
+            endif
+          enddo
+       else
+          do j=1,N_det
+             index_good_state_array(j) = j
+             good_state_array(j) = .True.
+          enddo
+       endif
+       if(i_state .ne.0)then
+         ! Fill the first "i_state" states that have a correct S^2 value
+         do j = 1, i_state
+           do i=1,N_det
+             ci_eigenvectors_complex(i,j) = eigenvectors(i,index_good_state_array(j))
+           enddo
+           ci_electronic_energy_complex(j) = eigenvalues(index_good_state_array(j))
+           ci_s2_complex(j) = s2_eigvalues(index_good_state_array(j))
+         enddo
+         i_other_state = 0
+         do j = 1, N_det
+           if(good_state_array(j))cycle
+           i_other_state +=1
+           if(i_state+i_other_state.gt.n_states_diag)then
+             exit
+           endif
+           do i=1,N_det
+             ci_eigenvectors_complex(i,i_state+i_other_state) = eigenvectors(i,j)
+           enddo
+           ci_electronic_energy_complex(i_state+i_other_state) = eigenvalues(j)
+           ci_s2_complex(i_state+i_other_state) = s2_eigvalues(i_state+i_other_state)
+         enddo
+
+       else
+         print*,''
+         print*,'!!!!!!!!   WARNING  !!!!!!!!!'
+         print*,'  Within the ',N_det,'determinants selected'
+         print*,'  and the ',N_states_diag,'states requested'
+         print*,'  We did not find any state with S^2 values close to ',expected_s2
+         print*,'  We will then set the first N_states eigenvectors of the H matrix'
+         print*,'  as the ci_eigenvectors_complex'
+         print*,'  You should consider more states and maybe ask for s2_eig to be .True. or just enlarge the CI space'
+         print*,''
+         do j=1,min(N_states_diag,N_det)
+           do i=1,N_det
+             ci_eigenvectors_complex(i,j) = eigenvectors(i,j)
+           enddo
+           ci_electronic_energy_complex(j) = eigenvalues(j)
+           ci_s2_complex(j) = s2_eigvalues(j)
+         enddo
+       endif
+       deallocate(index_good_state_array,good_state_array)
+       deallocate(s2_eigvalues)
+     else
+       call lapack_diag_complex(eigenvalues,eigenvectors,                      &
+           H_matrix_all_dets_complex,size(H_matrix_all_dets_complex,1),N_det)
+       ci_electronic_energy_complex(:) = 0.d0
+       call u_0_S2_u_0_complex(ci_s2_complex,eigenvectors,N_det,psi_det,N_int,&
+          min(N_det,N_states_diag),size(eigenvectors,1))
+       ! Select the "N_states_diag" states of lowest energy
+       do j=1,min(N_det,N_states_diag)
+         do i=1,N_det
+           ci_eigenvectors_complex(i,j) = eigenvectors(i,j)
+         enddo
+         ci_electronic_energy_complex(j) = eigenvalues(j)
+       enddo
+     endif
+     do k=1,N_states_diag
+       ci_electronic_energy_complex(k) = 0.d0
+       do j=1,N_det
+         do i=1,N_det
+           !todo: accumulate imag parts to test? (should sum to zero)
+           ci_electronic_energy_complex(k) +=                                &
+               dble(dconjg(ci_eigenvectors_complex(i,k)) * ci_eigenvectors_complex(j,k) *  &
+               H_matrix_all_dets_complex(i,j))
+         enddo
+       enddo
+     enddo
+     deallocate(eigenvectors,eigenvalues)
+   endif
+
+END_PROVIDER
+
+subroutine diagonalize_CI_complex
+  implicit none
+  BEGIN_DOC
+!  Replace the coefficients of the |CI| states by the coefficients of the
+!  eigenstates of the |CI| matrix.
+  END_DOC
+  integer :: i,j
+  do j=1,N_states
+    do i=1,N_det
+      psi_coef_complex(i,j) = ci_eigenvectors_complex(i,j)
+    enddo
+  enddo
+  psi_energy(1:N_states) = CI_electronic_energy(1:N_states)
+  psi_s2(1:N_states) = CI_s2(1:N_states)
+  !todo: touch ci_{s2,electronic_energy}?
+  SOFT_TOUCH psi_coef_complex CI_electronic_energy_complex ci_energy CI_eigenvectors_complex CI_s2_complex psi_energy psi_s2
+end
+
 subroutine diagonalize_CI
   implicit none
   BEGIN_DOC
@@ -222,5 +444,6 @@ subroutine diagonalize_CI
   psi_energy(1:N_states) = CI_electronic_energy(1:N_states)
   psi_s2(1:N_states) = CI_s2(1:N_states)
 
-  SOFT_TOUCH psi_coef CI_electronic_energy CI_energy CI_eigenvectors CI_s2 psi_energy psi_s2
+  !todo: touch ci_{s2,electronic_energy}?
+  SOFT_TOUCH psi_coef CI_electronic_energy_real ci_energy CI_eigenvectors CI_s2_real psi_energy psi_s2
 end

src/davidson/print_e_components.irp.f

@@ -5,7 +5,8 @@ subroutine print_energy_components()
   END_DOC
   integer, save :: ifirst = 0
   double precision :: Vee, Ven, Vnn, Vecp, T, f
-  integer  :: i,j,k
+  complex*16 :: fc
+  integer  :: i,j,k,kk
 
   Vnn = nuclear_repulsion
 
@@ -17,15 +18,32 @@ subroutine print_energy_components()
     Ven  = 0.d0
     Vecp = 0.d0
     T    = 0.d0
-
-    do j=1,mo_num
-      do i=1,mo_num
-        f = one_e_dm_mo_alpha(i,j,k) + one_e_dm_mo_beta(i,j,k)
-        Ven  = Ven  + f * mo_integrals_n_e(i,j)
-        Vecp = Vecp + f * mo_pseudo_integrals(i,j)
-        T    = T    + f * mo_kinetic_integrals(i,j)
+    
+    if (is_complex) then
+      do kk=1,kpt_num
+        do j=1,mo_num_per_kpt
+          do i=1,mo_num_per_kpt
+            !fc = one_e_dm_mo_alpha_complex(i,j,k) + one_e_dm_mo_beta_complex(i,j,k)
+            !Ven  = Ven  + dble(fc * mo_integrals_n_e_complex(j,i))
+            !Vecp = Vecp + dble(fc * mo_pseudo_integrals_complex(j,i))
+            !T    = T    + dble(fc * mo_kinetic_integrals_complex(j,i))
+            fc = one_e_dm_mo_alpha_kpts(i,j,kk,k) + one_e_dm_mo_beta_kpts(i,j,kk,k)
+            Ven  = Ven  + dble(fc * mo_integrals_n_e_kpts(j,i,kk))
+            Vecp = Vecp + dble(fc * mo_pseudo_integrals_kpts(j,i,kk))
+            T    = T    + dble(fc * mo_kinetic_integrals_kpts(j,i,kk))
+          enddo
+        enddo
       enddo
-    enddo
+    else
+      do j=1,mo_num
+        do i=1,mo_num
+          f = one_e_dm_mo_alpha(i,j,k) + one_e_dm_mo_beta(i,j,k)
+          Ven  = Ven  + f * mo_integrals_n_e(i,j)
+          Vecp = Vecp + f * mo_pseudo_integrals(i,j)
+          T    = T    + f * mo_kinetic_integrals(i,j)
+        enddo
+      enddo
+    endif
     Vee = psi_energy(k) - Ven - Vecp - T
     
     if (ifirst == 0) then

src/davidson/u0_h_u0.irp.f

@@ -5,8 +5,13 @@
 ! psi_energy(i) = $\langle \Psi_i | H | \Psi_i \rangle$
 ! 
 ! psi_s2(i) = $\langle \Psi_i | S^2 | \Psi_i \rangle$
+! real and complex
   END_DOC
-  call u_0_H_u_0(psi_energy,psi_s2,psi_coef,N_det,psi_det,N_int,N_states,psi_det_size)
+  if (is_complex) then
+    call u_0_h_u_0_complex(psi_energy,psi_s2,psi_coef_complex,N_det,psi_det,N_int,N_states,psi_det_size)
+  else
+    call u_0_H_u_0(psi_energy,psi_s2,psi_coef,N_det,psi_det,N_int,N_states,psi_det_size)
+  endif
   integer :: i
   do i=N_det+1,N_states
     psi_energy(i) = 0.d0
@@ -708,3 +713,702 @@ N_int;;
 END_TEMPLATE
 
 
+!==============================================================================!
+!                                                                              !
+!                                    Complex                                   !
+!                                                                              !
+!==============================================================================!
+
+subroutine u_0_H_u_0_complex(e_0,s_0,u_0,n,keys_tmp,Nint,N_st,sze)
+  !todo: check normalization for complex
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Computes $E_0 = \frac{\langle u_0 | H | u_0 \rangle}{\langle u_0 | u_0 \rangle}$
+  !
+  ! and      $S_0 = \frac{\langle u_0 | S^2 | u_0 \rangle}{\langle u_0 | u_0 \rangle}$
+  !
+  ! n : number of determinants
+  !
+  END_DOC
+  integer, intent(in)             :: n,Nint, N_st, sze
+  double precision, intent(out)   :: e_0(N_st),s_0(N_st)
+  complex*16, intent(inout)       :: u_0(sze,N_st)
+  integer(bit_kind),intent(in)    :: keys_tmp(Nint,2,n)
+
+  complex*16, allocatable         :: v_0(:,:), s_vec(:,:), u_1(:,:)
+  double precision                :: u_dot_u_complex,diag_H_mat_elem
+  complex*16                      :: u_dot_v_complex
+  integer                         :: i,j, istate
+
+  if ((n > 100000).and.distributed_davidson) then
+    allocate (v_0(n,N_states_diag),s_vec(n,N_states_diag), u_1(n,N_states_diag))
+    u_1(:,:) = (0.d0,0.d0)
+    u_1(1:n,1:N_st) = u_0(1:n,1:N_st)
+    call h_s2_u_0_nstates_zmq_complex(v_0,s_vec,u_1,N_states_diag,n)
+  else if (n < n_det_max_full) then
+    allocate (v_0(n,N_st),s_vec(n,N_st), u_1(n,N_st))
+    v_0(:,:) = (0.d0,0.d0)
+    u_1(:,:) = (0.d0,0.d0)
+    s_vec(:,:) = (0.d0,0.d0)
+    u_1(1:n,1:N_st) = u_0(1:n,1:N_st)
+    do istate = 1,N_st
+      do j=1,n
+        do i=1,n
+          v_0(i,istate) = v_0(i,istate) + h_matrix_all_dets_complex(i,j) * u_0(j,istate)
+          s_vec(i,istate) = s_vec(i,istate) + S2_matrix_all_dets(i,j) * u_0(j,istate)
+        enddo
+      enddo
+    enddo
+  else
+    allocate (v_0(n,N_st),s_vec(n,N_st),u_1(n,N_st))
+    u_1(:,:) = (0.d0,0.d0)
+    u_1(1:n,1:N_st) = u_0(1:n,1:N_st)
+    call h_s2_u_0_nstates_openmp_complex(v_0,s_vec,u_1,N_st,n)
+  endif
+  u_0(1:n,1:N_st) = u_1(1:n,1:N_st)
+  deallocate(u_1)
+  double precision :: norm
+  !$OMP PARALLEL DO PRIVATE(i,norm) DEFAULT(SHARED)
+  do i=1,N_st
+    norm = u_dot_u_complex(u_0(1,i),n)
+    if (norm /= 0.d0) then
+      !todo: should these be normalized? is u_0 already normalized? (if so, where?)
+      e_0(i) = dble(u_dot_v_complex(v_0(1,i),u_0(1,i),n))
+      s_0(i) = dble(u_dot_v_complex(s_vec(1,i),u_0(1,i),n))
+    else
+      e_0(i) = 0.d0
+      s_0(i) = 0.d0
+    endif
+  enddo
+  !$OMP END PARALLEL DO
+  deallocate (s_vec, v_0)
+end
+
+
+subroutine H_S2_u_0_nstates_openmp_complex(v_0,s_0,u_0,N_st,sze)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Computes $v_0 = H | u_0\rangle$ and $s_0 = S^2  | u_0\rangle$.
+  !
+  ! 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
+  complex*16, intent(inout)  :: v_0(sze,N_st), s_0(sze,N_st), u_0(sze,N_st)
+  integer :: k
+  complex*16, allocatable  :: u_t(:,:), v_t(:,:), s_t(:,:)
+  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: u_t
+  allocate(u_t(N_st,N_det),v_t(N_st,N_det),s_t(N_st,N_det))
+
+  do k=1,N_st
+    call cdset_order(u_0(1,k),psi_bilinear_matrix_order,N_det)
+  enddo
+  v_t = (0.d0,0.d0)
+  s_t = (0.d0,0.d0)
+  call cdtranspose(                                                   &
+      u_0,                                                           &
+      size(u_0, 1),                                                  &
+      u_t,                                                           &
+      size(u_t, 1),                                                  &
+      N_det, N_st)
+
+  call h_s2_u_0_nstates_openmp_work_complex(v_t,s_t,u_t,N_st,sze,1,N_det,0,1)
+  deallocate(u_t)
+
+  call cdtranspose(                                                   &
+      v_t,                                                           &
+      size(v_t, 1),                                                  &
+      v_0,                                                           &
+      size(v_0, 1),                                                  &
+      N_st, N_det)
+  call cdtranspose(                                                   &
+      s_t,                                                           &
+      size(s_t, 1),                                                  &
+      s_0,                                                           &
+      size(s_0, 1),                                                  &
+      N_st, N_det)
+  deallocate(v_t,s_t)
+
+  do k=1,N_st
+    call cdset_order(v_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
+    call cdset_order(s_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
+    call cdset_order(u_0(1,k),psi_bilinear_matrix_order_reverse,N_det)
+  enddo
+
+end
+subroutine h_s2_u_0_nstates_openmp_work_complex(v_t,s_t,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
+  complex*16, intent(in)   :: u_t(N_st,N_det)
+  complex*16, intent(out)  :: v_t(N_st,sze), s_t(N_st,sze)
+
+
+  PROVIDE ref_bitmask_energy N_int
+
+  select case (N_int)
+    case (1)
+      call H_S2_u_0_nstates_openmp_work_complex_1(v_t,s_t,u_t,N_st,sze,istart,iend,ishift,istep)
+    case (2)
+      call H_S2_u_0_nstates_openmp_work_complex_2(v_t,s_t,u_t,N_st,sze,istart,iend,ishift,istep)
+    case (3)
+      call H_S2_u_0_nstates_openmp_work_complex_3(v_t,s_t,u_t,N_st,sze,istart,iend,ishift,istep)
+    case (4)
+      call H_S2_u_0_nstates_openmp_work_complex_4(v_t,s_t,u_t,N_st,sze,istart,iend,ishift,istep)
+    case default
+      call H_S2_u_0_nstates_openmp_work_complex_N_int(v_t,s_t,u_t,N_st,sze,istart,iend,ishift,istep)
+  end select
+end
+
+BEGIN_TEMPLATE
+
+subroutine H_S2_u_0_nstates_openmp_work_complex_$N_int(v_t,s_t,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
+  complex*16, intent(in)         :: u_t(N_st,N_det)
+  complex*16, intent(out)        :: v_t(N_st,sze), s_t(N_st,sze)
+
+  complex*16                     :: hij, sij
+  integer                        :: i,j,k,l,kk
+  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
+  logical                        :: compute_singles
+  integer*8                      :: last_found, left, right, right_max
+  double precision               :: rss, mem, ratio
+  complex*16, allocatable        :: utl(:,:)
+  integer, parameter             :: block_size=128
+
+!  call resident_memory(rss)
+!  mem = dble(singles_beta_csc_size) / 1024.d0**3
+!
+!  compute_singles = (mem+rss > qp_max_mem)
+!
+!  if (.not.compute_singles) then
+!    provide singles_beta_csc
+!  endif
+compute_singles=.True.
+
+  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(SHARED) 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, compute_singles,      &
+      !$OMP          singles_alpha_csc,singles_alpha_csc_idx,        &
+      !$OMP          singles_beta_csc,singles_beta_csc_idx)          &
+      !$OMP   PRIVATE(krow, kcol, tmp_det, spindet, k_a, k_b, i,     &
+      !$OMP          lcol, lrow, l_a, l_b, utl, kk,                  &
+      !$OMP          buffer, doubles, n_doubles,                     &
+      !$OMP          tmp_det2, hij, sij, idx, l, kcol_prev,          &
+      !$OMP          singles_a, n_singles_a, singles_b, ratio,       &
+      !$OMP          n_singles_b, k8, last_found,left,right,right_max)
+
+  ! Alpha/Beta double excitations
+  ! =============================
+
+  allocate( buffer($N_int,maxab),                                     &
+      singles_a(maxab),                                              &
+      singles_b(maxab),                                              &
+      doubles(maxab),                                                &
+      idx(maxab), utl(N_st,block_size))
+
+  kcol_prev=-1
+
+  ASSERT (iend <= N_det)
+  ASSERT (istart > 0)
+  ASSERT (istep  > 0)
+
+  !$OMP DO SCHEDULE(guided,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)
+
+    if (kcol /= kcol_prev) then
+      tmp_det(1:$N_int,2) = psi_det_beta_unique (1:$N_int, kcol)
+      if (compute_singles) 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)
+      else
+        n_singles_b = 0
+        !DIR$ LOOP COUNT avg(1000)
+        do k8=singles_beta_csc_idx(kcol),singles_beta_csc_idx(kcol+1)-1
+          n_singles_b = n_singles_b+1
+          singles_b(n_singles_b) = singles_beta_csc(k8)
+        enddo
+      endif
+    endif
+    kcol_prev = kcol
+
+    ! Loop over singly excited beta columns
+    ! -------------------------------------
+
+    !DIR$ LOOP COUNT avg(1000)
+    do i=1,n_singles_b
+      lcol = singles_b(i)
+
+      tmp_det2(1:$N_int,2) = psi_det_beta_unique(1:$N_int, lcol)
+
+!---
+!      if (compute_singles) then
+
+        l_a = psi_bilinear_matrix_columns_loc(lcol)
+        ASSERT (l_a <= N_det)
+
+        !DIR$ UNROLL(8)
+        !DIR$ LOOP COUNT avg(50000)
+        do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol)
+          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)  ! hot spot
+
+          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 )
+
+!-----
+!      else
+!
+! ! Search for singles
+!
+!call cpu_time(time0)
+! ! Right boundary
+!        l_a = psi_bilinear_matrix_columns_loc(lcol+1)-1
+!        ASSERT (l_a <= N_det)
+!        do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol)
+!          lrow = psi_bilinear_matrix_rows(l_a)
+!          ASSERT (lrow <= N_det_alpha_unique)
+!
+!          left = singles_alpha_csc_idx(krow)
+!          right_max = -1_8
+!          right = singles_alpha_csc_idx(krow+1)
+!          do while (right-left>0_8)
+!            k8 = shiftr(right+left,1)
+!            if (singles_alpha_csc(k8) > lrow) then
+!              right = k8
+!            else if (singles_alpha_csc(k8) < lrow) then
+!              left = k8 + 1_8
+!            else
+!              right_max = k8+1_8
+!              exit
+!            endif
+!          enddo
+!          if (right_max > 0_8) exit
+!          l_a = l_a-1
+!        enddo
+!        if (right_max < 0_8) right_max = singles_alpha_csc_idx(krow)
+!
+! ! Search
+!        n_singles_a = 0
+!        l_a = psi_bilinear_matrix_columns_loc(lcol)
+!        ASSERT (l_a <= N_det)
+!
+!        last_found = singles_alpha_csc_idx(krow)
+!        do j=1,psi_bilinear_matrix_columns_loc(lcol+1) - psi_bilinear_matrix_columns_loc(lcol)
+!          lrow = psi_bilinear_matrix_rows(l_a)
+!          ASSERT (lrow <= N_det_alpha_unique)
+!
+!          left = last_found
+!          right = right_max
+!          do while (right-left>0_8)
+!            k8 = shiftr(right+left,1)
+!            if (singles_alpha_csc(k8) > lrow) then
+!              right = k8
+!            else if (singles_alpha_csc(k8) < lrow) then
+!              left = k8 + 1_8
+!            else
+!              n_singles_a += 1
+!              singles_a(n_singles_a) = l_a
+!              last_found = k8+1_8
+!              exit
+!            endif
+!          enddo
+!          l_a = l_a+1
+!        enddo
+!        j = j-1
+!
+!      endif
+!-----
+
+      ! Loop over alpha singles
+      ! -----------------------
+
+      !DIR$ LOOP COUNT avg(1000)
+      do k = 1,n_singles_a,block_size
+        ! Prefetch u_t(:,l_a)
+        do kk=0,block_size-1
+          if (k+kk > n_singles_a) exit
+          l_a = singles_a(k+kk)
+          ASSERT (l_a <= N_det)
+
+          do l=1,N_st
+            utl(l,kk+1) = u_t(l,l_a)
+          enddo
+        enddo
+
+        do kk=0,block_size-1
+          if (k+kk > n_singles_a) exit
+          l_a = singles_a(k+kk)
+          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)
+          !todo: check arg order conjg/noconjg (should be okay)
+          call i_h_j_double_alpha_beta_complex(tmp_det,tmp_det2,$N_int,hij)
+          call get_s2(tmp_det,tmp_det2,$N_int,sij)
+          !DIR$ LOOP COUNT AVG(4)
+          do l=1,N_st
+          !todo: check arg order conjg/noconjg (should be okay)
+            v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1)
+            s_t(l,k_a) = s_t(l,k_a) + sij * utl(l,kk+1)
+          enddo
+        enddo
+      enddo
+
+    enddo
+
+  enddo
+  !$OMP END DO
+
+  !$OMP DO SCHEDULE(guided,64)
+  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)
+    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)
+
+    !DIR$ LOOP COUNT avg(200000)
+    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) ! Hot spot
+      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)
+    !DIR$ LOOP COUNT avg(1000)
+    do i=1,n_singles_a,block_size
+      ! Prefetch u_t(:,l_a)
+      do kk=0,block_size-1
+        if (i+kk > n_singles_a) exit
+        l_a = singles_a(i+kk)
+        ASSERT (l_a <= N_det)
+
+        do l=1,N_st
+          utl(l,kk+1) = u_t(l,l_a)
+        enddo
+      enddo
+
+      do kk=0,block_size-1
+        if (i+kk > n_singles_a) exit
+        l_a = singles_a(i+kk)
+        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)
+        !todo: check arg order conjg/noconjg (should be okay)
+        call i_h_j_single_spin_complex( tmp_det, tmp_det2, $N_int, 1, hij)
+
+        !DIR$ LOOP COUNT AVG(4)
+        do l=1,N_st
+        !todo: check arg order conjg/noconjg (should be okay)
+          v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1)
+          ! single => sij = 0
+        enddo
+      enddo
+    enddo
+
+
+    ! Compute Hij for all alpha doubles
+    ! ----------------------------------
+
+    !DIR$ LOOP COUNT avg(50000)
+    do i=1,n_doubles,block_size
+      ! Prefetch u_t(:,l_a)
+      do kk=0,block_size-1
+        if (i+kk > n_doubles) exit
+        l_a = doubles(i+kk)
+        ASSERT (l_a <= N_det)
+
+        do l=1,N_st
+          utl(l,kk+1) = u_t(l,l_a)
+        enddo
+      enddo
+
+      do kk=0,block_size-1
+        if (i+kk > n_doubles) exit
+        l_a = doubles(i+kk)
+        lrow = psi_bilinear_matrix_rows(l_a)
+        ASSERT (lrow <= N_det_alpha_unique)
+
+        !todo: check arg order conjg/noconjg (should be okay)
+        call i_h_j_double_spin_complex( tmp_det(1,1), psi_det_alpha_unique(1, lrow), $N_int, hij)
+        !DIR$ LOOP COUNT AVG(4)
+        do l=1,N_st
+        !todo: check arg order conjg/noconjg (should be okay)
+          v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1)
+          ! same spin => sij = 0
+        enddo
+      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)
+    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)
+    !DIR$ LOOP COUNT avg(200000)
+    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)
+    !DIR$ LOOP COUNT avg(1000)
+    do i=1,n_singles_b,block_size
+      do kk=0,block_size-1
+        if (i+kk > n_singles_b) exit
+        l_b = singles_b(i+kk)
+        ASSERT (l_b <= N_det)
+
+        l_a = psi_bilinear_matrix_transp_order(l_b)
+        ASSERT (l_a <= N_det)
+
+        do l=1,N_st
+          utl(l,kk+1) = u_t(l,l_a)
+        enddo
+      enddo
+
+      do kk=0,block_size-1
+        if (i+kk > n_singles_b) exit
+        l_b = singles_b(i+kk)
+        l_a = psi_bilinear_matrix_transp_order(l_b)
+        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)
+        call i_h_j_single_spin_complex( tmp_det, tmp_det2, $N_int, 2, hij)
+        !DIR$ LOOP COUNT AVG(4)
+        do l=1,N_st
+          !todo: check arg order conjg/noconjg (should be okay)
+          v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1)
+          ! single => sij = 0
+        enddo
+      enddo
+    enddo
+
+    ! Compute Hij for all beta doubles
+    ! ----------------------------------
+
+    !DIR$ LOOP COUNT avg(50000)
+    do i=1,n_doubles,block_size
+      do kk=0,block_size-1
+        if (i+kk > n_doubles) exit
+        l_b = doubles(i+kk)
+        ASSERT (l_b <= N_det)
+        l_a = psi_bilinear_matrix_transp_order(l_b)
+        ASSERT (l_a <= N_det)
+
+        do l=1,N_st
+          utl(l,kk+1) = u_t(l,l_a)
+        enddo
+      enddo
+
+      do kk=0,block_size-1
+        if (i+kk > n_doubles) exit
+        l_b = doubles(i+kk)
+        l_a = psi_bilinear_matrix_transp_order(l_b)
+        lcol = psi_bilinear_matrix_transp_columns(l_b)
+        ASSERT (lcol <= N_det_beta_unique)
+
+        !todo: check arg order conjg/noconjg (should be okay)
+        call i_h_j_double_spin_complex( tmp_det(1,2), psi_det_beta_unique(1, lcol), $N_int, hij)
+
+        !DIR$ LOOP COUNT AVG(4)
+        do l=1,N_st
+          !todo: check arg order conjg/noconjg (should be okay)
+          v_t(l,k_a) = v_t(l,k_a) + hij * utl(l,kk+1)
+          ! same spin => sij = 0
+        enddo
+      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, diag_S_mat_elem
+
+    hij = dcmplx(diag_H_mat_elem(tmp_det,$N_int),0.d0)
+    sij = dcmplx(diag_S_mat_elem(tmp_det,$N_int),0.d0)
+    !DIR$ LOOP COUNT AVG(4)
+    do l=1,N_st
+      v_t(l,k_a) = v_t(l,k_a) + hij * u_t(l,k_a)
+      s_t(l,k_a) = s_t(l,k_a) + sij * u_t(l,k_a)
+    enddo
+
+  end do
+  !$OMP END DO
+  deallocate(buffer, singles_a, singles_b, doubles, idx, utl)
+  !$OMP END PARALLEL
+
+end
+
+SUBST [ N_int ]
+
+1;;
+2;;
+3;;
+4;;
+N_int;;
+
+END_TEMPLATE
+
+

src/determinants/EZFIO.cfg

@@ -84,6 +84,12 @@ doc: Coefficients of the wave function
 type: double precision 
 size: (determinants.n_det,determinants.n_states)
 
+[psi_coef_complex]
+interface: ezfio
+doc: Coefficients of the wave function
+type: double precision 
+size: (2,determinants.n_det,determinants.n_states)
+
 [psi_det]
 interface: ezfio
 doc: Determinants of the variational space
@@ -96,6 +102,12 @@ doc: Coefficients of the wave function
 type: double precision 
 size: (determinants.n_det_qp_edit,determinants.n_states)
 
+[psi_coef_complex_qp_edit]
+interface: ezfio
+doc: Coefficients of the wave function
+type: double precision 
+size: (2,determinants.n_det_qp_edit,determinants.n_states)
+
 [psi_det_qp_edit]
 interface: ezfio
 doc: Determinants of the variational space

src/determinants/create_excitations.irp.f

@@ -80,6 +80,33 @@ subroutine build_singly_excited_wavefunction(i_hole,i_particle,ispin,det_out,coe
   enddo
 end
 
+subroutine build_singly_excited_wavefunction_complex(i_hole,i_particle,ispin,det_out,coef_out)
+  implicit none
+  BEGIN_DOC
+  ! Applies the single excitation operator : a^{dager}_(i_particle) a_(i_hole) of
+  ! spin = ispin to the current wave function (psi_det, psi_coef)
+  END_DOC
+  integer, intent(in)            :: i_hole,i_particle,ispin
+  integer(bit_kind), intent(out) :: det_out(N_int,2,N_det)
+  complex*16, intent(out)  :: coef_out(N_det,N_states)
+
+  integer :: k
+  integer :: i_ok
+  double precision :: phase
+  do k=1,N_det
+    coef_out(k,:) = psi_coef(k,:)
+    det_out(:,:,k) = psi_det(:,:,k)
+    call do_single_excitation(det_out(1,1,k),i_hole,i_particle,ispin,i_ok)
+    if (i_ok == 1) then
+      call get_phase(psi_det(1,1,k), det_out(1,1,k),phase,N_int)
+      coef_out(k,:) = phase * coef_out(k,:)
+    else
+      coef_out(k,:) = (0.d0,0.d0)
+      det_out(:,:,k) = psi_det(:,:,k)
+    endif
+  enddo
+end
+
 logical function is_spin_flip_possible(key_in,i_flip,ispin)
   implicit none
   BEGIN_DOC

src/determinants/density_matrix.irp.f

@@ -248,29 +248,58 @@ BEGIN_PROVIDER [ double precision, one_e_spin_density_mo, (mo_num,mo_num) ]
 END_PROVIDER
 
 subroutine set_natural_mos
-   implicit none
-   BEGIN_DOC
-   ! Set natural orbitals, obtained by diagonalization of the one-body density matrix
-   ! in the |MO| basis
-   END_DOC
-   character*(64)                 :: label
-   double precision, allocatable  :: tmp(:,:)
+  implicit none
+  BEGIN_DOC
+  ! Set natural orbitals, obtained by diagonalization of the one-body density matrix
+  ! in the |MO| basis
+  END_DOC
+  character*(64)                 :: label
+  double precision, allocatable  :: tmp(:,:)
 
-   label = "Natural"
-    integer :: i,j,iorb,jorb
-    do i = 1, n_virt_orb
-     iorb = list_virt(i)
-     do j = 1, n_core_inact_act_orb
-      jorb = list_core_inact_act(j)
-      if(one_e_dm_mo(iorb,jorb).ne. 0.d0)then
-        print*,'AHAHAH'
-        print*,iorb,jorb,one_e_dm_mo(iorb,jorb)
-        stop
-      endif
-     enddo
+  label = "Natural"
+  integer :: i,j,iorb,jorb,k
+  if (is_complex) then
+
+    !todo: implement for kpts
+    do k=1,kpt_num
+      do i = 1, n_virt_orb_kpts(k)
+        iorb = list_virt_kpts(i,k)
+        do j = 1, n_core_inact_act_orb_kpts(k)
+          jorb = list_core_inact_act_kpts(j,k)
+          if(cdabs(one_e_dm_mo_kpts(iorb,jorb,k)).ne. 0.d0)then
+            print*,'AHAHAH'
+            print*,iorb,jorb,k,one_e_dm_mo_kpts(iorb,jorb,k)
+            stop
+          endif
+        enddo
+      enddo
     enddo
-   call mo_as_svd_vectors_of_mo_matrix_eig(one_e_dm_mo,size(one_e_dm_mo,1),mo_num,mo_num,mo_occ,label)
-   soft_touch mo_occ
+    !print*,'1RDM'
+    !do k=1,kpt_num
+    !  do j=1,mo_num_per_kpt
+    !    do i=1,mo_num_per_kpt
+    !      print'(3(I5),2(E25.15))',i,j,k,one_e_dm_mo_kpts(i,j,k)
+    !    enddo
+    !  enddo
+    !enddo
+!    call mo_as_svd_vectors_of_mo_matrix_eig_complex(one_e_dm_mo_complex,size(one_e_dm_mo_complex,1),mo_num,mo_num,mo_occ,label)
+    call mo_as_svd_vectors_of_mo_matrix_eig_kpts(one_e_dm_mo_kpts,size(one_e_dm_mo_kpts,1),mo_num_per_kpt,mo_num_per_kpt,kpt_num,mo_occ_kpts,label)
+    soft_touch mo_occ_kpts
+  else
+    do i = 1, n_virt_orb
+      iorb = list_virt(i)
+      do j = 1, n_core_inact_act_orb
+        jorb = list_core_inact_act(j)
+        if(one_e_dm_mo(iorb,jorb).ne. 0.d0)then
+          print*,'AHAHAH'
+          print*,iorb,jorb,one_e_dm_mo(iorb,jorb)
+          stop
+        endif
+      enddo
+    enddo
+    call mo_as_svd_vectors_of_mo_matrix_eig(one_e_dm_mo,size(one_e_dm_mo,1),mo_num,mo_num,mo_occ,label)
+    soft_touch mo_occ
+  endif
 
 end
 subroutine save_natural_mos
@@ -292,11 +321,19 @@ BEGIN_PROVIDER [ double precision, c0_weight, (N_states) ]
    if (N_states > 1) then
      integer                        :: i
      double precision               :: c
+     if (is_complex) then
+       do i=1,N_states
+         c0_weight(i) = 1.d-31
+         c = maxval(cdabs(psi_coef_complex(:,i) * psi_coef_complex(:,i)))
+         c0_weight(i) = 1.d0/(c+1.d-20)
+       enddo
+     else
      do i=1,N_states
        c0_weight(i) = 1.d-31
        c = maxval(psi_coef(:,i) * psi_coef(:,i))
        c0_weight(i) = 1.d0/(c+1.d-20)
      enddo
+     endif
      c = 1.d0/minval(c0_weight(:))
      do i=1,N_states
        c0_weight(i) = c0_weight(i) * c
@@ -398,8 +435,23 @@ subroutine get_occupation_from_dets(istate,occupation)
   ASSERT (istate <= N_states)
 
   occupation = 0.d0
-  double precision, external :: u_dot_u
+  
+  if (is_complex) then
+    double precision, external :: u_dot_u_complex
+    norm_2 = 1.d0/u_dot_u_complex(psi_coef_complex(1,istate),N_det)
 
+    do i=1,N_det
+      c = cdabs(psi_coef_complex(i,istate)*psi_coef_complex(i,istate))*norm_2
+      call bitstring_to_list_ab(psi_det(1,1,i), list, n_elements, N_int)
+      do ispin=1,2
+        do j=1,n_elements(ispin)
+          ASSERT ( list(j,ispin) < mo_num )
+          occupation( list(j,ispin) ) += c
+        enddo
+      enddo
+    enddo
+  else
+  double precision, external :: u_dot_u
   norm_2 = 1.d0/u_dot_u(psi_coef(1,istate),N_det)
 
   do i=1,N_det
@@ -412,5 +464,6 @@ subroutine get_occupation_from_dets(istate,occupation)
       enddo
     enddo
   enddo
+  endif
 end
 

src/determinants/density_matrix_cplx.irp.f

@@ -0,0 +1,694 @@
+ BEGIN_PROVIDER [ complex*16, one_e_dm_mo_alpha_average_complex, (mo_num,mo_num) ]
+&BEGIN_PROVIDER [ complex*16, one_e_dm_mo_beta_average_complex, (mo_num,mo_num) ]
+   implicit none
+   BEGIN_DOC
+   ! $\alpha$ and $\beta$ one-body density matrix for each state
+   END_DOC
+   integer                        :: i
+   one_e_dm_mo_alpha_average_complex = (0.d0,0.d0)
+   one_e_dm_mo_beta_average_complex  = (0.d0,0.d0)
+   do i = 1,N_states
+     one_e_dm_mo_alpha_average_complex(:,:) += one_e_dm_mo_alpha_complex(:,:,i) * state_average_weight(i)
+     one_e_dm_mo_beta_average_complex(:,:) += one_e_dm_mo_beta_complex(:,:,i) * state_average_weight(i)
+   enddo
+END_PROVIDER
+
+BEGIN_PROVIDER [ complex*16, one_e_dm_mo_diff_complex, (mo_num,mo_num,2:N_states) ]
+  implicit none
+  BEGIN_DOC
+  ! Difference of the one-body density matrix with respect to the ground state
+  END_DOC
+  integer                        :: i,j, istate
+
+  do istate=2,N_states
+    do j=1,mo_num
+      do i=1,mo_num
+        one_e_dm_mo_diff_complex(i,j,istate) =                            &
+            one_e_dm_mo_alpha_complex(i,j,istate) - one_e_dm_mo_alpha_complex(i,j,1) +&
+            one_e_dm_mo_beta_complex (i,j,istate) - one_e_dm_mo_beta_complex (i,j,1)
+      enddo
+    enddo
+  enddo
+
+END_PROVIDER
+
+
+BEGIN_PROVIDER [ complex*16, one_e_dm_mo_spin_index_complex, (mo_num,mo_num,N_states,2) ]
+  implicit none
+  integer                        :: i,j,ispin,istate
+  ispin = 1
+  do istate = 1, N_states
+    do j = 1, mo_num
+      do i = 1, mo_num
+        one_e_dm_mo_spin_index_complex(i,j,istate,ispin) = one_e_dm_mo_alpha_complex(i,j,istate)
+      enddo
+    enddo
+  enddo
+
+  ispin = 2
+  do istate = 1, N_states
+    do j = 1, mo_num
+      do i = 1, mo_num
+        one_e_dm_mo_spin_index_complex(i,j,istate,ispin) = one_e_dm_mo_beta_complex(i,j,istate)
+      enddo
+    enddo
+  enddo
+
+END_PROVIDER
+
+
+BEGIN_PROVIDER [ complex*16, one_e_dm_dagger_mo_spin_index_complex, (mo_num,mo_num,N_states,2) ]
+  print*,irp_here,' not implemented for complex'
+  stop -1
+!   implicit none
+!   integer                        :: i,j,ispin,istate
+!   ispin = 1
+!   do istate = 1, N_states
+!     do j = 1, mo_num
+!       one_e_dm_dagger_mo_spin_index(j,j,istate,ispin) = 1 - one_e_dm_mo_alpha(j,j,istate)
+!       do i = j+1, mo_num
+!         one_e_dm_dagger_mo_spin_index(i,j,istate,ispin) = -one_e_dm_mo_alpha(i,j,istate)
+!         one_e_dm_dagger_mo_spin_index(j,i,istate,ispin) = -one_e_dm_mo_alpha(i,j,istate)
+!       enddo
+!     enddo
+!   enddo
+!
+!   ispin = 2
+!   do istate = 1, N_states
+!     do j = 1, mo_num
+!       one_e_dm_dagger_mo_spin_index(j,j,istate,ispin) = 1 - one_e_dm_mo_beta(j,j,istate)
+!       do i = j+1, mo_num
+!         one_e_dm_dagger_mo_spin_index(i,j,istate,ispin) = -one_e_dm_mo_beta(i,j,istate)
+!         one_e_dm_dagger_mo_spin_index(j,i,istate,ispin) = -one_e_dm_mo_beta(i,j,istate)
+!       enddo
+!     enddo
+!   enddo
+!
+END_PROVIDER
+
+ BEGIN_PROVIDER [ complex*16, one_e_dm_mo_alpha_complex, (mo_num,mo_num,N_states) ]
+&BEGIN_PROVIDER [ complex*16, one_e_dm_mo_beta_complex, (mo_num,mo_num,N_states) ]
+  implicit none
+  BEGIN_DOC
+  ! $\alpha$ and $\beta$ one-body density matrix for each state
+  ! $\gamma_{\mu\nu} = \langle\Psi|a_{\nu}^{\dagger}a_{\mu}|\Psi\rangle$
+  ! $\gamma_{\mu\nu} = \langle a_{\nu} \Psi|a_{\mu} \Psi\rangle$
+  ! $\gamma_{\mu\nu} = \sum_{IJ} c^*_J c_I \langle a_{\nu} I|a_{\mu} J\rangle$
+  END_DOC
+
+  integer                        :: j,k,l,m,k_a,k_b
+  integer                        :: occ(N_int*bit_kind_size,2)
+  complex*16               :: ck, cl, ckl
+  double precision               :: phase
+  integer                        :: h1,h2,p1,p2,s1,s2, degree
+  integer(bit_kind)              :: tmp_det(N_int,2), tmp_det2(N_int)
+  integer                        :: exc(0:2,2),n_occ(2)
+  complex*16, allocatable  :: tmp_a(:,:,:), tmp_b(:,:,:)
+  integer                        :: krow, kcol, lrow, lcol
+
+  PROVIDE psi_det psi_coef_complex
+
+  one_e_dm_mo_alpha_complex = (0.d0,0.d0)
+  one_e_dm_mo_beta_complex  = (0.d0,0.d0)
+  !$OMP PARALLEL DEFAULT(NONE)                                      &
+      !$OMP PRIVATE(j,k,k_a,k_b,l,m,occ,ck, cl, ckl,phase,h1,h2,p1,p2,s1,s2, degree,exc,&
+      !$OMP  tmp_a, tmp_b, n_occ, krow, kcol, lrow, lcol, tmp_det, tmp_det2)&
+      !$OMP SHARED(psi_det,psi_coef_complex,N_int,N_states,elec_alpha_num,  &
+      !$OMP  elec_beta_num,one_e_dm_mo_alpha_complex,one_e_dm_mo_beta_complex,N_det,&
+      !$OMP  mo_num,psi_bilinear_matrix_rows,psi_bilinear_matrix_columns,&
+      !$OMP  psi_bilinear_matrix_transp_rows, psi_bilinear_matrix_transp_columns,&
+      !$OMP  psi_bilinear_matrix_order_reverse, psi_det_alpha_unique, psi_det_beta_unique,&
+      !$OMP  psi_bilinear_matrix_values_complex, psi_bilinear_matrix_transp_values_complex,&
+      !$OMP  N_det_alpha_unique,N_det_beta_unique,irp_here)
+  allocate(tmp_a(mo_num,mo_num,N_states), tmp_b(mo_num,mo_num,N_states) )
+  tmp_a = (0.d0,0.d0)
+  !$OMP DO SCHEDULE(dynamic,64)
+  do k_a=1,N_det
+    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)
+
+    ! Diagonal part
+    ! -------------
+
+    call bitstring_to_list_ab(tmp_det, occ, n_occ, N_int)
+    do m=1,N_states
+      ck = cdabs(psi_bilinear_matrix_values_complex(k_a,m)*psi_bilinear_matrix_values_complex(k_a,m))
+      do l=1,elec_alpha_num
+        j = occ(l,1)
+        tmp_a(j,j,m) += ck
+      enddo
+    enddo
+
+    if (k_a == N_det) cycle
+    l = k_a+1
+    lrow = psi_bilinear_matrix_rows(l)
+    lcol = psi_bilinear_matrix_columns(l)
+    ! Fix beta determinant, loop over alphas
+    do while ( lcol == kcol )
+      tmp_det2(:) = psi_det_alpha_unique(:, lrow)
+      call get_excitation_degree_spin(tmp_det(1,1),tmp_det2,degree,N_int)
+      if (degree == 1) then
+        exc = 0
+        call get_single_excitation_spin(tmp_det(1,1),tmp_det2,exc,phase,N_int)
+        call decode_exc_spin(exc,h1,p1,h2,p2)
+        ! h1 occ in k
+        ! p1 occ in l
+        do m=1,N_states
+          ckl = dconjg(psi_bilinear_matrix_values_complex(k_a,m))*psi_bilinear_matrix_values_complex(l,m) * phase
+          tmp_a(h1,p1,m) += dconjg(ckl)
+          tmp_a(p1,h1,m) += ckl
+        enddo
+      endif
+      l = l+1
+      if (l>N_det) exit
+      lrow = psi_bilinear_matrix_rows(l)
+      lcol = psi_bilinear_matrix_columns(l)
+    enddo
+
+  enddo
+  !$OMP END DO NOWAIT
+
+  !$OMP CRITICAL
+  one_e_dm_mo_alpha_complex(:,:,:) = one_e_dm_mo_alpha_complex(:,:,:) + tmp_a(:,:,:)
+  !$OMP END CRITICAL
+  deallocate(tmp_a)
+
+  tmp_b = (0.d0,0.d0)
+  !$OMP DO SCHEDULE(dynamic,64)
+  do k_b=1,N_det
+    krow = psi_bilinear_matrix_transp_rows(k_b)
+    ASSERT (krow <= N_det_alpha_unique)
+
+    kcol = psi_bilinear_matrix_transp_columns(k_b)
+    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)
+
+    ! Diagonal part
+    ! -------------
+
+    call bitstring_to_list_ab(tmp_det, occ, n_occ, N_int)
+    do m=1,N_states
+      ck = cdabs(psi_bilinear_matrix_transp_values_complex(k_b,m)*psi_bilinear_matrix_transp_values_complex(k_b,m))
+      do l=1,elec_beta_num
+        j = occ(l,2)
+        tmp_b(j,j,m) += ck
+      enddo
+    enddo
+
+    if (k_b == N_det) cycle
+    l = k_b+1
+    lrow = psi_bilinear_matrix_transp_rows(l)
+    lcol = psi_bilinear_matrix_transp_columns(l)
+    ! Fix beta determinant, loop over alphas
+    do while ( lrow == krow )
+      tmp_det2(:) = psi_det_beta_unique(:, lcol)
+      call get_excitation_degree_spin(tmp_det(1,2),tmp_det2,degree,N_int)
+      if (degree == 1) then
+        exc = 0
+        call get_single_excitation_spin(tmp_det(1,2),tmp_det2,exc,phase,N_int)
+        call decode_exc_spin(exc,h1,p1,h2,p2)
+        do m=1,N_states
+          ckl = dconjg(psi_bilinear_matrix_transp_values_complex(k_b,m))*psi_bilinear_matrix_transp_values_complex(l,m) * phase
+          tmp_b(h1,p1,m) += dconjg(ckl)
+          tmp_b(p1,h1,m) += ckl
+        enddo
+      endif
+      l = l+1
+      if (l>N_det) exit
+      lrow = psi_bilinear_matrix_transp_rows(l)
+      lcol = psi_bilinear_matrix_transp_columns(l)
+    enddo
+
+  enddo
+  !$OMP END DO NOWAIT
+  !$OMP CRITICAL
+  one_e_dm_mo_beta_complex(:,:,:)  = one_e_dm_mo_beta_complex(:,:,:)  + tmp_b(:,:,:)
+  !$OMP END CRITICAL
+
+  deallocate(tmp_b)
+  !$OMP END PARALLEL
+
+END_PROVIDER
+
+BEGIN_PROVIDER [ complex*16, one_e_dm_mo_complex, (mo_num,mo_num) ]
+   implicit none
+   BEGIN_DOC
+   ! One-body density matrix
+   END_DOC
+   one_e_dm_mo_complex = one_e_dm_mo_alpha_average_complex + one_e_dm_mo_beta_average_complex
+END_PROVIDER
+
+BEGIN_PROVIDER [ complex*16, one_e_spin_density_mo_complex, (mo_num,mo_num) ]
+   implicit none
+   BEGIN_DOC
+   ! $\rho(\alpha) - \rho(\beta)$
+   END_DOC
+   one_e_spin_density_mo_complex = one_e_dm_mo_alpha_average_complex - one_e_dm_mo_beta_average_complex
+END_PROVIDER
+
+
+BEGIN_PROVIDER [ complex*16, one_e_spin_density_ao_complex, (ao_num,ao_num) ]
+   BEGIN_DOC
+   ! One body spin density matrix on the |AO| basis : $\rho_{AO}(\alpha) - \rho_{AO}(\beta)$
+   ! todo: verify that this is correct for complex
+   ! equivalent to using mo_to_ao_no_overlap?
+   END_DOC
+   implicit none
+   integer                        :: i,j,k,l
+   complex*16               :: dm_mo
+
+   one_e_spin_density_ao_complex = (0.d0,0.d0)
+   do k = 1, ao_num
+     do l = 1, ao_num
+       do i = 1, mo_num
+         do j = 1, mo_num
+           dm_mo = one_e_spin_density_mo_complex(j,i)
+           !    if(dabs(dm_mo).le.1.d-10)cycle
+           one_e_spin_density_ao_complex(l,k) += dconjg(mo_coef_complex(k,i)) * mo_coef_complex(l,j) * dm_mo
+
+         enddo
+       enddo
+     enddo
+   enddo
+
+END_PROVIDER
+
+ BEGIN_PROVIDER [ complex*16, one_e_dm_ao_alpha_complex, (ao_num,ao_num) ]
+&BEGIN_PROVIDER [ complex*16, one_e_dm_ao_beta_complex, (ao_num,ao_num) ]
+   BEGIN_DOC
+   ! One body density matrix on the |AO| basis : $\rho_{AO}(\alpha), \rho_{AO}(\beta)$.
+   END_DOC
+   implicit none
+   integer                        :: i,j,k,l
+   complex*16               :: mo_alpha,mo_beta
+
+   one_e_dm_ao_alpha_complex = (0.d0,0.d0)
+   one_e_dm_ao_beta_complex = (0.d0,0.d0)
+   do k = 1, ao_num
+     do l = 1, ao_num
+       do i = 1, mo_num
+         do j = 1, mo_num
+           mo_alpha = one_e_dm_mo_alpha_average_complex(j,i)
+           mo_beta = one_e_dm_mo_beta_average_complex(j,i)
+           !    if(dabs(dm_mo).le.1.d-10)cycle
+           one_e_dm_ao_alpha_complex(l,k) += dconjg(mo_coef_complex(k,i)) * mo_coef_complex(l,j) *  mo_alpha
+           one_e_dm_ao_beta_complex(l,k) += dconjg(mo_coef_complex(k,i)) * mo_coef_complex(l,j)  *  mo_beta
+         enddo
+       enddo
+     enddo
+   enddo
+
+END_PROVIDER
+
+
+!============================================!
+!                                            !
+!                    kpts                    !
+!                                            !
+!============================================!
+
+ BEGIN_PROVIDER [ complex*16, one_e_dm_mo_alpha_average_kpts, (mo_num_per_kpt,mo_num_per_kpt,kpt_num) ]
+&BEGIN_PROVIDER [ complex*16, one_e_dm_mo_beta_average_kpts, (mo_num_per_kpt,mo_num_per_kpt,kpt_num) ]
+   implicit none
+   BEGIN_DOC
+   ! $\alpha$ and $\beta$ one-body density matrix for each state
+   END_DOC
+   integer                        :: i,k
+   one_e_dm_mo_alpha_average_kpts = (0.d0,0.d0)
+   one_e_dm_mo_beta_average_kpts  = (0.d0,0.d0)
+   do i = 1,N_states
+     do k=1,kpt_num
+       one_e_dm_mo_alpha_average_kpts(:,:,k) += one_e_dm_mo_alpha_kpts(:,:,k,i) * state_average_weight(i)
+       one_e_dm_mo_beta_average_kpts(:,:,k) += one_e_dm_mo_beta_kpts(:,:,k,i) * state_average_weight(i)
+     enddo
+   enddo
+END_PROVIDER
+
+BEGIN_PROVIDER [ complex*16, one_e_dm_mo_diff_kpts, (mo_num_per_kpt,mo_num_per_kpt,kpt_num,2:N_states) ]
+  implicit none
+  BEGIN_DOC
+  ! Difference of the one-body density matrix with respect to the ground state
+  END_DOC
+  integer                        :: i,j, istate,k
+
+  do istate=2,N_states
+    do k=1,kpt_num
+      do j=1,mo_num_per_kpt
+        do i=1,mo_num_per_kpt
+          one_e_dm_mo_diff_kpts(i,j,k,istate) =                            &
+              one_e_dm_mo_alpha_kpts(i,j,k,istate) - one_e_dm_mo_alpha_kpts(i,j,k,1) +&
+              one_e_dm_mo_beta_kpts (i,j,k,istate) - one_e_dm_mo_beta_kpts (i,j,k,1)
+        enddo
+      enddo
+    enddo
+  enddo
+
+END_PROVIDER
+
+
+BEGIN_PROVIDER [ complex*16, one_e_dm_mo_spin_index_kpts, (mo_num_per_kpt,mo_num_per_kpt,kpt_num,N_states,2) ]
+  implicit none
+  integer                        :: i,j,k,ispin,istate
+  ispin = 1
+  do istate = 1, N_states
+    do k=1,kpt_num
+      do j = 1, mo_num_per_kpt
+        do i = 1, mo_num_per_kpt
+          one_e_dm_mo_spin_index_kpts(i,j,k,istate,ispin) = one_e_dm_mo_alpha_kpts(i,j,k,istate)
+        enddo
+      enddo
+    enddo
+  enddo
+
+  ispin = 2
+  do istate = 1, N_states
+    do k=1,kpt_num
+      do j = 1, mo_num_per_kpt
+        do i = 1, mo_num_per_kpt
+          one_e_dm_mo_spin_index_kpts(i,j,k,istate,ispin) = one_e_dm_mo_beta_kpts(i,j,k,istate)
+        enddo
+      enddo
+    enddo
+  enddo
+
+END_PROVIDER
+
+
+BEGIN_PROVIDER [ complex*16, one_e_dm_dagger_mo_spin_index_kpts, (mo_num_per_kpt,mo_num_per_kpt,kpt_num,N_states,2) ]
+  print*,irp_here,' not implemented for kpts'
+  stop -1
+!   implicit none
+!   integer                        :: i,j,ispin,istate
+!   ispin = 1
+!   do istate = 1, N_states
+!     do j = 1, mo_num
+!       one_e_dm_dagger_mo_spin_index(j,j,istate,ispin) = 1 - one_e_dm_mo_alpha(j,j,istate)
+!       do i = j+1, mo_num
+!         one_e_dm_dagger_mo_spin_index(i,j,istate,ispin) = -one_e_dm_mo_alpha(i,j,istate)
+!         one_e_dm_dagger_mo_spin_index(j,i,istate,ispin) = -one_e_dm_mo_alpha(i,j,istate)
+!       enddo
+!     enddo
+!   enddo
+!
+!   ispin = 2
+!   do istate = 1, N_states
+!     do j = 1, mo_num
+!       one_e_dm_dagger_mo_spin_index(j,j,istate,ispin) = 1 - one_e_dm_mo_beta(j,j,istate)
+!       do i = j+1, mo_num
+!         one_e_dm_dagger_mo_spin_index(i,j,istate,ispin) = -one_e_dm_mo_beta(i,j,istate)
+!         one_e_dm_dagger_mo_spin_index(j,i,istate,ispin) = -one_e_dm_mo_beta(i,j,istate)
+!       enddo
+!     enddo
+!   enddo
+!
+END_PROVIDER
+
+ BEGIN_PROVIDER [ complex*16, one_e_dm_mo_alpha_kpts, (mo_num_per_kpt,mo_num_per_kpt,kpt_num,N_states) ]
+&BEGIN_PROVIDER [ complex*16, one_e_dm_mo_beta_kpts, (mo_num_per_kpt,mo_num_per_kpt,kpt_num,N_states) ]
+  implicit none
+  BEGIN_DOC
+  ! $\alpha$ and $\beta$ one-body density matrix for each state
+  ! $\gamma_{\mu\nu} = \langle\Psi|a_{\nu}^{\dagger}a_{\mu}|\Psi\rangle$
+  ! $\gamma_{\mu\nu} = \langle a_{\nu} \Psi|a_{\mu} \Psi\rangle$
+  ! $\gamma_{\mu\nu} = \sum_{IJ} c^*_J c_I \langle a_{\nu} I|a_{\mu} J\rangle$
+  END_DOC
+  !todo: implement for kpts
+  integer                        :: j,k,l,m,k_a,k_b
+  integer                        :: occ(N_int*bit_kind_size,2)
+  complex*16               :: ck, cl, ckl
+  double precision               :: phase
+  integer                        :: h1,h2,p1,p2,s1,s2, degree
+  integer                        :: ih1,ip1,kh1,kp1,kk,k_shft,ii
+  integer(bit_kind)              :: tmp_det(N_int,2), tmp_det2(N_int)
+  integer(bit_kind)              :: tmp_det_kpts(N_int,2)
+  integer                        :: exc(0:2,2),n_occ(2)
+  complex*16, allocatable  :: tmp_a(:,:,:,:), tmp_b(:,:,:,:)
+  integer                        :: krow, kcol, lrow, lcol
+
+  PROVIDE psi_det psi_coef_complex
+
+  one_e_dm_mo_alpha_kpts = (0.d0,0.d0)
+  one_e_dm_mo_beta_kpts  = (0.d0,0.d0)
+  !$OMP PARALLEL DEFAULT(NONE)                                      &
+      !$OMP PRIVATE(j,k,k_a,k_b,l,m,occ,ck, cl, ckl,phase,h1,h2,p1,p2,s1,s2, degree,exc,&
+      !$OMP  tmp_a, tmp_b, n_occ, krow, kcol, lrow, lcol, tmp_det, tmp_det2,ih1,ip1,kh1,kp1,kk,&
+      !$OMP  tmp_det_kpts,k_shft,ii)&
+      !$OMP SHARED(psi_det,psi_coef_complex,N_int,N_states,elec_alpha_num_kpts,  &
+      !$OMP  elec_beta_num_kpts,one_e_dm_mo_alpha_kpts,one_e_dm_mo_beta_kpts,N_det,&
+      !$OMP  mo_num_per_kpt,psi_bilinear_matrix_rows,psi_bilinear_matrix_columns,&
+      !$OMP  psi_bilinear_matrix_transp_rows, psi_bilinear_matrix_transp_columns,&
+      !$OMP  psi_bilinear_matrix_order_reverse, psi_det_alpha_unique, psi_det_beta_unique,&
+      !$OMP  psi_bilinear_matrix_values_complex, psi_bilinear_matrix_transp_values_complex,&
+      !$OMP  N_det_alpha_unique,N_det_beta_unique,irp_here,kpt_num,kpts_bitmask)
+  allocate(tmp_a(mo_num_per_kpt,mo_num_per_kpt,kpt_num,N_states), tmp_b(mo_num_per_kpt,mo_num_per_kpt,kpt_num,N_states) )
+  tmp_a = (0.d0,0.d0)
+  !$OMP DO SCHEDULE(dynamic,64)
+  do k_a=1,N_det
+    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)
+
+    ! Diagonal part
+    ! -------------
+
+    do kk=1,kpt_num
+      k_shft = (kk-1)*mo_num_per_kpt
+      do ii=1,N_int
+        tmp_det_kpts(ii,1) = iand(tmp_det(ii,1),kpts_bitmask(ii,kk))
+        tmp_det_kpts(ii,2) = iand(tmp_det(ii,2),kpts_bitmask(ii,kk))
+      enddo
+      call bitstring_to_list_ab(tmp_det_kpts, occ, n_occ, N_int)
+      do m=1,N_states
+        ck = cdabs(psi_bilinear_matrix_values_complex(k_a,m)*psi_bilinear_matrix_values_complex(k_a,m))
+        !do l=1,elec_alpha_num_kpts(kk)
+        do l=1,n_occ(1)
+          j = occ(l,1) - k_shft
+          tmp_a(j,j,kk,m) += ck
+        enddo
+      enddo
+    enddo
+
+    if (k_a == N_det) cycle
+    l = k_a+1
+    lrow = psi_bilinear_matrix_rows(l)
+    lcol = psi_bilinear_matrix_columns(l)
+    ! Fix beta determinant, loop over alphas
+    do while ( lcol == kcol )
+      tmp_det2(:) = psi_det_alpha_unique(:, lrow)
+      call get_excitation_degree_spin(tmp_det(1,1),tmp_det2,degree,N_int)
+      if (degree == 1) then
+        exc = 0
+        call get_single_excitation_spin(tmp_det(1,1),tmp_det2,exc,phase,N_int)
+        call decode_exc_spin(exc,h1,p1,h2,p2)
+        ! h1 occ in k
+        ! p1 occ in l
+        ih1 = mod(h1-1,mo_num_per_kpt)+1
+        ip1 = mod(p1-1,mo_num_per_kpt)+1
+        kh1 = (h1-1)/mo_num_per_kpt + 1
+        kp1 = (p1-1)/mo_num_per_kpt + 1
+        if (kh1.ne.kp1) then
+          print *,'problem in: ',irp_here,'a'
+          print *,' h1 = ',h1
+          print *,' p1 = ',p1
+          print *,'ih1 = ',ih1
+          print *,'ip1 = ',ip1
+          print *,'kh1 = ',kh1
+          print *,'kp1 = ',kp1
+          !call debug_det(tmp_det,N_int)
+          call debug_single_spindet(tmp_det(1,1),N_int)
+          call debug_single_spindet(tmp_det2,N_int)
+          call debug_single_spindet(tmp_det(1,2),N_int)
+          !call print_spindet(tmp_det2,N_int)
+          stop -2
+        endif
+        do m=1,N_states
+          ckl = dconjg(psi_bilinear_matrix_values_complex(k_a,m))*psi_bilinear_matrix_values_complex(l,m) * phase
+          tmp_a(ih1,ip1,kh1,m) += dconjg(ckl)
+          tmp_a(ip1,ih1,kh1,m) += ckl
+        enddo
+      endif
+      l = l+1
+      if (l>N_det) exit
+      lrow = psi_bilinear_matrix_rows(l)
+      lcol = psi_bilinear_matrix_columns(l)
+    enddo
+
+  enddo
+  !$OMP END DO NOWAIT
+
+  !$OMP CRITICAL
+  one_e_dm_mo_alpha_kpts(:,:,:,:) = one_e_dm_mo_alpha_kpts(:,:,:,:) + tmp_a(:,:,:,:)
+  !$OMP END CRITICAL
+  deallocate(tmp_a)
+
+  tmp_b = (0.d0,0.d0)
+  !$OMP DO SCHEDULE(dynamic,64)
+  do k_b=1,N_det
+    krow = psi_bilinear_matrix_transp_rows(k_b)
+    ASSERT (krow <= N_det_alpha_unique)
+
+    kcol = psi_bilinear_matrix_transp_columns(k_b)
+    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)
+
+    ! Diagonal part
+    ! -------------
+
+    do kk=1,kpt_num
+      k_shft = (kk-1)*mo_num_per_kpt
+      do ii=1,N_int
+        tmp_det_kpts(ii,1) = iand(tmp_det(ii,1),kpts_bitmask(ii,kk))
+        tmp_det_kpts(ii,2) = iand(tmp_det(ii,2),kpts_bitmask(ii,kk))
+      enddo
+      call bitstring_to_list_ab(tmp_det_kpts, occ, n_occ, N_int)
+      do m=1,N_states
+        ck = cdabs(psi_bilinear_matrix_transp_values_complex(k_b,m)*psi_bilinear_matrix_transp_values_complex(k_b,m))
+        do l=1,n_occ(2)
+          j = occ(l,2) - k_shft
+          tmp_b(j,j,kk,m) += ck
+        enddo
+      enddo
+    enddo
+
+    if (k_b == N_det) cycle
+    l = k_b+1
+    lrow = psi_bilinear_matrix_transp_rows(l)
+    lcol = psi_bilinear_matrix_transp_columns(l)
+    ! Fix beta determinant, loop over alphas
+    do while ( lrow == krow )
+      tmp_det2(:) = psi_det_beta_unique(:, lcol)
+      call get_excitation_degree_spin(tmp_det(1,2),tmp_det2,degree,N_int)
+      if (degree == 1) then
+        exc = 0
+        call get_single_excitation_spin(tmp_det(1,2),tmp_det2,exc,phase,N_int)
+        call decode_exc_spin(exc,h1,p1,h2,p2)
+        ih1 = mod(h1-1,mo_num_per_kpt)+1
+        ip1 = mod(p1-1,mo_num_per_kpt)+1
+        kh1 = (h1-1)/mo_num_per_kpt + 1
+        kp1 = (p1-1)/mo_num_per_kpt + 1
+        if (kh1.ne.kp1) then
+          print *,'problem in: ',irp_here,'b'
+          print *,' h1 = ',h1
+          print *,' p1 = ',p1
+          print *,'ih1 = ',ih1
+          print *,'ip1 = ',ip1
+          print *,'kh1 = ',kh1
+          print *,'kp1 = ',kp1
+          call debug_single_spindet(tmp_det(1,2),N_int)
+          call debug_single_spindet(tmp_det2,N_int)
+          call debug_single_spindet(tmp_det(1,1),N_int)
+          stop -3
+        endif
+        do m=1,N_states
+          ckl = dconjg(psi_bilinear_matrix_transp_values_complex(k_b,m))*psi_bilinear_matrix_transp_values_complex(l,m) * phase
+          tmp_b(ih1,ip1,kh1,m) += dconjg(ckl)
+          tmp_b(ip1,ih1,kh1,m) += ckl
+        enddo
+      endif
+      l = l+1
+      if (l>N_det) exit
+      lrow = psi_bilinear_matrix_transp_rows(l)
+      lcol = psi_bilinear_matrix_transp_columns(l)
+    enddo
+
+  enddo
+  !$OMP END DO NOWAIT
+  !$OMP CRITICAL
+  one_e_dm_mo_beta_kpts(:,:,:,:)  = one_e_dm_mo_beta_kpts(:,:,:,:)  + tmp_b(:,:,:,:)
+  !$OMP END CRITICAL
+
+  deallocate(tmp_b)
+  !$OMP END PARALLEL
+
+END_PROVIDER
+
+BEGIN_PROVIDER [ complex*16, one_e_dm_mo_kpts, (mo_num_per_kpt,mo_num_per_kpt,kpt_num) ]
+   implicit none
+   BEGIN_DOC
+   ! One-body density matrix
+   END_DOC
+   one_e_dm_mo_kpts = one_e_dm_mo_alpha_average_kpts + one_e_dm_mo_beta_average_kpts
+END_PROVIDER
+
+BEGIN_PROVIDER [ complex*16, one_e_spin_density_mo_kpts, (mo_num_per_kpt,mo_num_per_kpt,kpt_num) ]
+   implicit none
+   BEGIN_DOC
+   ! $\rho(\alpha) - \rho(\beta)$
+   END_DOC
+   one_e_spin_density_mo_kpts = one_e_dm_mo_alpha_average_kpts - one_e_dm_mo_beta_average_kpts
+END_PROVIDER
+
+
+BEGIN_PROVIDER [ complex*16, one_e_spin_density_ao_kpts, (ao_num_per_kpt,ao_num_per_kpt,kpt_num) ]
+   BEGIN_DOC
+   ! One body spin density matrix on the |AO| basis : $\rho_{AO}(\alpha) - \rho_{AO}(\beta)$
+   ! todo: verify that this is correct for complex
+   ! equivalent to using mo_to_ao_no_overlap?
+   END_DOC
+   implicit none
+   integer                        :: i,j,k,l,kk
+   complex*16               :: dm_mo
+
+   one_e_spin_density_ao_kpts = (0.d0,0.d0)
+   do kk=1,kpt_num
+     do k = 1, ao_num_per_kpt
+       do l = 1, ao_num_per_kpt
+         do i = 1, mo_num_per_kpt
+           do j = 1, mo_num_per_kpt
+             dm_mo = one_e_spin_density_mo_kpts(j,i,kk)
+             !    if(dabs(dm_mo).le.1.d-10)cycle
+             one_e_spin_density_ao_kpts(l,k,kk) += dconjg(mo_coef_kpts(k,i,kk)) * mo_coef_kpts(l,j,kk) * dm_mo
+
+           enddo
+         enddo
+       enddo
+     enddo
+   enddo
+
+END_PROVIDER
+
+ BEGIN_PROVIDER [ complex*16, one_e_dm_ao_alpha_kpts, (ao_num_per_kpt,ao_num_per_kpt,kpt_num) ]
+&BEGIN_PROVIDER [ complex*16, one_e_dm_ao_beta_kpts, (ao_num_per_kpt,ao_num_per_kpt,kpt_num) ]
+   BEGIN_DOC
+   ! One body density matrix on the |AO| basis : $\rho_{AO}(\alpha), \rho_{AO}(\beta)$.
+   END_DOC
+   implicit none
+   integer                        :: i,j,k,l,kk
+   complex*16               :: mo_alpha,mo_beta
+
+   one_e_dm_ao_alpha_kpts = (0.d0,0.d0)
+   one_e_dm_ao_beta_kpts = (0.d0,0.d0)
+   do kk=1,kpt_num
+     do k = 1, ao_num_per_kpt
+       do l = 1, ao_num_per_kpt
+         do i = 1, mo_num_per_kpt
+           do j = 1, mo_num_per_kpt
+             mo_alpha = one_e_dm_mo_alpha_average_kpts(j,i,kk)
+             mo_beta = one_e_dm_mo_beta_average_kpts(j,i,kk)
+             !    if(dabs(dm_mo).le.1.d-10)cycle
+             one_e_dm_ao_alpha_kpts(l,k,kk) += dconjg(mo_coef_kpts(k,i,kk)) * mo_coef_kpts(l,j,kk) *  mo_alpha
+             one_e_dm_ao_beta_kpts(l,k,kk) += dconjg(mo_coef_kpts(k,i,kk)) * mo_coef_kpts(l,j,kk)  *  mo_beta
+           enddo
+         enddo
+       enddo
+     enddo
+   enddo
+
+END_PROVIDER
+
+

src/determinants/determinants.irp.f

@@ -113,7 +113,12 @@ BEGIN_PROVIDER [ integer(bit_kind), psi_det, (N_int,2,psi_det_size) ]
   logical                        :: exists
   character*(64)                 :: label
 
-  PROVIDE read_wf N_det mo_label ezfio_filename HF_bitmask mo_coef
+  PROVIDE read_wf N_det mo_label ezfio_filename HF_bitmask
+  if (is_complex) then
+    PROVIDE mo_coef_complex
+  else
+    PROVIDE mo_coef
+  endif
   psi_det = 0_bit_kind
   if (mpi_master) then
     if (read_wf) then
@@ -244,12 +249,21 @@ BEGIN_PROVIDER [ double precision, psi_average_norm_contrib, (psi_det_size) ]
   double precision               :: f
 
   psi_average_norm_contrib(:) = 0.d0
+  if (is_complex) then
+    do k=1,N_states
+      do i=1,N_det
+        psi_average_norm_contrib(i) = psi_average_norm_contrib(i) +    &
+            cdabs(psi_coef_complex(i,k)*psi_coef_complex(i,k))*state_average_weight(k)
+      enddo
+    enddo
+  else
   do k=1,N_states
     do i=1,N_det
       psi_average_norm_contrib(i) = psi_average_norm_contrib(i) +    &
           psi_coef(i,k)*psi_coef(i,k)*state_average_weight(k)
     enddo
   enddo
+  endif
   f = 1.d0/sum(psi_average_norm_contrib(1:N_det))
   do i=1,N_det
     psi_average_norm_contrib(i) = psi_average_norm_contrib(i)*f
@@ -266,7 +280,6 @@ END_PROVIDER
 
 
  BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted, (N_int,2,psi_det_size) ]
-&BEGIN_PROVIDER [ double precision, psi_coef_sorted, (psi_det_size,N_states) ]
 &BEGIN_PROVIDER [ double precision, psi_average_norm_contrib_sorted, (psi_det_size) ]
 &BEGIN_PROVIDER [ integer, psi_det_sorted_order, (psi_det_size) ]
    implicit none
@@ -288,9 +301,6 @@ END_PROVIDER
        psi_det_sorted(j,1,i) = psi_det(j,1,iorder(i))
        psi_det_sorted(j,2,i) = psi_det(j,2,iorder(i))
      enddo
-     do k=1,N_states
-       psi_coef_sorted(i,k) = psi_coef(iorder(i),k)
-     enddo
      psi_average_norm_contrib_sorted(i) = -psi_average_norm_contrib_sorted(i)
    enddo
    do i=1,N_det
@@ -298,29 +308,74 @@ END_PROVIDER
    enddo
 
    psi_det_sorted(:,:,N_det+1:psi_det_size) = 0_bit_kind
-   psi_coef_sorted(N_det+1:psi_det_size,:) = 0.d0
    psi_average_norm_contrib_sorted(N_det+1:psi_det_size) = 0.d0
    psi_det_sorted_order(N_det+1:psi_det_size) = 0
 
    deallocate(iorder)
 
+END_PROVIDER
+BEGIN_PROVIDER [ double precision, psi_coef_sorted, (psi_det_size,N_states) ]
+  implicit none
+  integer                        :: i,j,k
+  do i=1,N_det
+    j=psi_det_sorted_order(i)
+    do k=1,N_states
+      psi_coef_sorted(j,k) = psi_coef(i,k)
+    enddo
+  enddo
+  psi_coef_sorted(N_det+1:psi_det_size,:) = 0.d0
 END_PROVIDER
 
  BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_bit, (N_int,2,psi_det_size) ]
-&BEGIN_PROVIDER [ double precision, psi_coef_sorted_bit, (psi_det_size,N_states) ]
-   implicit none
-   BEGIN_DOC
-   ! Determinants on which we apply $\langle i|H|psi \rangle$ for perturbation.
-   ! They are sorted by determinants interpreted as integers. Useful
-   ! to accelerate the search of a random determinant in the wave
-   ! function.
-   END_DOC
+&BEGIN_PROVIDER [ integer, psi_det_sorted_bit_order, (psi_det_size) ]
+  implicit none
+  integer :: i,j
+  integer*8, allocatable         :: bit_tmp(:)
+  integer*8, external            :: det_search_key
 
-   call sort_dets_by_det_search_key(N_det, psi_det, psi_coef, size(psi_coef,1),       &
-       psi_det_sorted_bit, psi_coef_sorted_bit, N_states)
+  allocate(bit_tmp(N_det))
 
+  do i=1,N_det
+    psi_det_sorted_bit_order(i) = i
+    !$DIR FORCEINLINE
+    bit_tmp(i) = det_search_key(psi_det(1,1,i),N_int)
+  enddo
+  call i8sort(bit_tmp,psi_det_sorted_bit_order,N_det)
+  do i=1,N_det
+    do j=1,N_int
+      psi_det_sorted_bit(j,1,i) = psi_det(j,1,psi_det_sorted_bit_order(i))
+      psi_det_sorted_bit(j,2,i) = psi_det(j,2,psi_det_sorted_bit_order(i))
+    enddo
+  enddo
+  deallocate(bit_tmp)
 END_PROVIDER
 
+BEGIN_PROVIDER [ double precision, psi_coef_sorted_bit, (psi_det_size,N_states) ]
+  implicit none
+  integer :: i,k
+  do i=1,N_det
+    do k=1,N_states
+      psi_coef_sorted_bit(i,k) = psi_coef(psi_det_sorted_bit_order(i),k)
+    enddo
+  enddo
+END_PROVIDER
+
+
+! BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_bit, (N_int,2,psi_det_size) ]
+!&BEGIN_PROVIDER [ double precision, psi_coef_sorted_bit, (psi_det_size,N_states) ]
+!   implicit none
+!   BEGIN_DOC
+!   ! Determinants on which we apply $\langle i|H|psi \rangle$ for perturbation.
+!   ! They are sorted by determinants interpreted as integers. Useful
+!   ! to accelerate the search of a random determinant in the wave
+!   ! function.
+!   END_DOC
+!
+!   call sort_dets_by_det_search_key(N_det, psi_det, psi_coef, size(psi_coef,1),       &
+!       psi_det_sorted_bit, psi_coef_sorted_bit, N_states)
+!
+!END_PROVIDER
+
 subroutine sort_dets_by_det_search_key(Ndet, det_in, coef_in, sze, det_out, coef_out, N_st)
    use bitmasks
    implicit none
@@ -369,24 +424,46 @@ end
 
  BEGIN_PROVIDER [ double precision, psi_coef_max, (N_states) ]
 &BEGIN_PROVIDER [ double precision, psi_coef_min, (N_states) ]
-&BEGIN_PROVIDER [ double precision, abs_psi_coef_max, (N_states) ]
-&BEGIN_PROVIDER [ double precision, abs_psi_coef_min, (N_states) ]
-   implicit none
-   BEGIN_DOC
-   ! Max and min values of the coefficients
-   END_DOC
-   integer                        :: i
-   do i=1,N_states
-     psi_coef_min(i) = minval(psi_coef(:,i))
-     psi_coef_max(i) = maxval(psi_coef(:,i))
-     abs_psi_coef_min(i) = minval( dabs(psi_coef(:,i)) )
-     abs_psi_coef_max(i) = maxval( dabs(psi_coef(:,i)) )
-     call write_double(6,psi_coef_max(i), 'Max coef')
-     call write_double(6,psi_coef_min(i), 'Min coef')
-     call write_double(6,abs_psi_coef_max(i), 'Max abs coef')
-     call write_double(6,abs_psi_coef_min(i), 'Min abs coef')
-   enddo
+  implicit none
+  BEGIN_DOC
+  ! Max and min values of the coefficients
+  END_DOC
+  integer                        :: i
+  if (is_complex) then
+    print*,irp_here,' not implemented for complex'
+    stop -1
+  endif
+  do i=1,N_states
+    psi_coef_min(i) = minval(psi_coef(:,i))
+    psi_coef_max(i) = maxval(psi_coef(:,i))
+    call write_double(6,psi_coef_max(i), 'Max coef')
+    call write_double(6,psi_coef_min(i), 'Min coef')
+  enddo
+END_PROVIDER
 
+
+ BEGIN_PROVIDER [ double precision, abs_psi_coef_max, (N_states) ]
+&BEGIN_PROVIDER [ double precision, abs_psi_coef_min, (N_states) ]
+  implicit none
+  BEGIN_DOC
+  ! Max and min magnitudes of the coefficients
+  END_DOC
+  integer                        :: i
+  if (is_complex) then
+    do i=1,N_states
+      abs_psi_coef_min(i) = minval( cdabs(psi_coef_complex(:,i)) )
+      abs_psi_coef_max(i) = maxval( cdabs(psi_coef_complex(:,i)) )
+      call write_double(6,abs_psi_coef_max(i), 'Max abs coef')
+      call write_double(6,abs_psi_coef_min(i), 'Min abs coef')
+    enddo
+  else
+    do i=1,N_states
+      abs_psi_coef_min(i) = minval( dabs(psi_coef(:,i)) )
+      abs_psi_coef_max(i) = maxval( dabs(psi_coef(:,i)) )
+      call write_double(6,abs_psi_coef_max(i), 'Max abs coef')
+      call write_double(6,abs_psi_coef_min(i), 'Min abs coef')
+    enddo
+  endif
 END_PROVIDER
 
 
@@ -442,10 +519,17 @@ end
 subroutine save_ref_determinant
   implicit none
   use bitmasks
+  if (is_complex) then
+    complex*16 :: buffer_c(1,N_states)
+    buffer_c = (0.d0,0.d0)
+    buffer_c(1,1) = (1.d0,0.d0)
+    call save_wavefunction_general_complex(1,N_states,ref_bitmask,1,buffer_c)
+  else
   double precision               :: buffer(1,N_states)
   buffer = 0.d0
   buffer(1,1) = 1.d0
   call save_wavefunction_general(1,N_states,ref_bitmask,1,buffer)
+  endif
 end
 
 
@@ -467,7 +551,12 @@ subroutine save_wavefunction_truncated(thr)
     endif
   enddo
   if (mpi_master) then
+    if (is_complex) then
+      call save_wavefunction_general_complex(N_det_save,min(N_states,N_det_save),&
+                psi_det_sorted,size(psi_coef_sorted_complex,1),psi_coef_sorted_complex)
+    else
     call save_wavefunction_general(N_det_save,min(N_states,N_det_save),psi_det_sorted,size(psi_coef_sorted,1),psi_coef_sorted)
+    endif
   endif
 end
 
@@ -485,7 +574,12 @@ subroutine save_wavefunction
     return
   endif
   if (mpi_master) then
+    if (is_complex) then
+      call save_wavefunction_general_complex(N_det,N_states,&
+                  psi_det_sorted,size(psi_coef_sorted_complex,1),psi_coef_sorted_complex)
+    else
     call save_wavefunction_general(N_det,N_states,psi_det_sorted,size(psi_coef_sorted,1),psi_coef_sorted)
+    endif
   endif
 end
 
@@ -497,7 +591,12 @@ subroutine save_wavefunction_unsorted
   !  Save the wave function into the |EZFIO| file
   END_DOC
   if (mpi_master) then
+    if (is_complex) then
+      call save_wavefunction_general_complex(N_det,min(N_states,N_det),&
+                   psi_det,size(psi_coef_complex,1),psi_coef_complex)
+    else
     call save_wavefunction_general(N_det,min(N_states,N_det),psi_det,size(psi_coef,1),psi_coef)
+    endif
   endif
 end
 

src/determinants/determinants_cplx.irp.f

@@ -0,0 +1,350 @@
+use bitmasks
+
+
+
+
+BEGIN_PROVIDER [ complex*16, psi_coef_complex, (psi_det_size,N_states) ]
+  implicit none
+  BEGIN_DOC
+  ! The wave function coefficients. Initialized with Hartree-Fock if the |EZFIO| file
+  ! is empty.
+  END_DOC
+
+  integer                        :: i,k, N_int2
+  logical                        :: exists
+  character*(64)                 :: label
+
+  PROVIDE read_wf N_det mo_label ezfio_filename
+  psi_coef_complex = (0.d0,0.d0)
+  do i=1,min(N_states,psi_det_size)
+    psi_coef_complex(i,i) = (1.d0,0.d0)
+  enddo
+
+  if (mpi_master) then
+    if (read_wf) then
+      call ezfio_has_determinants_psi_coef_complex(exists)
+      if (exists) then
+        call ezfio_has_determinants_mo_label(exists)
+        if (exists) then
+          call ezfio_get_determinants_mo_label(label)
+          exists = (label == mo_label)
+        endif
+      endif
+
+      if (exists) then
+
+        complex*16, allocatable  :: psi_coef_read(:,:)
+        allocate (psi_coef_read(N_det,N_states))
+        print *,  'Read psi_coef_complex', N_det, N_states
+        call ezfio_get_determinants_psi_coef_complex(psi_coef_read)
+        do k=1,N_states
+          do i=1,N_det
+            psi_coef_complex(i,k) = psi_coef_read(i,k)
+          enddo
+        enddo
+        deallocate(psi_coef_read)
+
+      endif
+    endif
+  endif
+  IRP_IF MPI_DEBUG
+    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( psi_coef_complex, size(psi_coef_complex), MPI_DOUBLE_COMPLEX, 0, MPI_COMM_WORLD, ierr)
+    if (ierr /= MPI_SUCCESS) then
+      stop 'Unable to read psi_coef_complex with MPI'
+    endif
+  IRP_ENDIF
+
+
+
+END_PROVIDER
+
+!==============================================================================!
+!                                                                              !
+!                               Sorting providers                              !
+!                                                                              !
+!==============================================================================!
+
+BEGIN_PROVIDER [ complex*16, psi_coef_sorted_complex, (psi_det_size,N_states) ]
+  implicit none
+  integer                        :: i,j,k
+  do i=1,N_det
+    j=psi_det_sorted_order(i)
+    do k=1,N_states
+      psi_coef_sorted_complex(j,k) = psi_coef_complex(i,k)
+    enddo
+  enddo
+  psi_coef_sorted_complex(N_det+1:psi_det_size,:) = (0.d0,0.d0)
+END_PROVIDER
+
+!!TODO: implement for complex (new psi_det_sorted? reuse? combine complex provider with real?)
+! BEGIN_PROVIDER [ integer(bit_kind), psi_det_sorted_complex, (N_int,2,psi_det_size) ]
+!&BEGIN_PROVIDER [ complex*16, psi_coef_sorted_complex, (psi_det_size,N_states) ]
+!&BEGIN_PROVIDER [ double precision, psi_average_norm_contrib_sorted_complex, (psi_det_size) ]
+!&BEGIN_PROVIDER [ integer, psi_det_sorted_order_complex, (psi_det_size) ]
+!   implicit none
+!   BEGIN_DOC
+!   ! Wave function sorted by determinants contribution to the norm (state-averaged)
+!   !
+!   ! psi_det_sorted_order(i) -> k : index in psi_det
+!   END_DOC
+!   integer                        :: i,j,k
+!   integer, allocatable           :: iorder(:)
+!   allocate ( iorder(N_det) )
+!   do i=1,N_det
+!     psi_average_norm_contrib_sorted_complex(i) = -psi_average_norm_contrib(i)
+!     iorder(i) = i
+!   enddo
+!   call dsort(psi_average_norm_contrib_sorted_complex,iorder,N_det)
+!   do i=1,N_det
+!     do j=1,N_int
+!       psi_det_sorted_complex(j,1,i) = psi_det(j,1,iorder(i))
+!       psi_det_sorted_complex(j,2,i) = psi_det(j,2,iorder(i))
+!     enddo
+!     do k=1,N_states
+!       psi_coef_sorted_complex(i,k) = psi_coef_complex(iorder(i),k)
+!     enddo
+!     psi_average_norm_contrib_sorted_complex(i) = -psi_average_norm_contrib_sorted_complex(i)
+!   enddo
+!   do i=1,N_det
+!     psi_det_sorted_order_complex(iorder(i)) = i
+!   enddo
+!
+!   psi_det_sorted_complex(:,:,N_det+1:psi_det_size) = 0_bit_kind
+!   psi_coef_sorted_complex(N_det+1:psi_det_size,:) = (0.d0,0.d0)
+!   psi_average_norm_contrib_sorted_complex(N_det+1:psi_det_size) = 0.d0
+!   psi_det_sorted_order_complex(N_det+1:psi_det_size) = 0
+!
+!   deallocate(iorder)
+!
+!END_PROVIDER
+
+
+BEGIN_PROVIDER [ complex*16, psi_coef_sorted_bit_complex, (psi_det_size,N_states) ]
+  implicit none
+  integer :: i,k
+  do i=1,N_det
+    do k=1,N_states
+      psi_coef_sorted_bit_complex(i,k) = psi_coef_complex(psi_det_sorted_bit_order(i),k)
+    enddo
+  enddo
+END_PROVIDER
+
+subroutine sort_dets_by_det_search_key_complex(Ndet, det_in, coef_in, sze, det_out, coef_out, N_st)
+   use bitmasks
+   implicit none
+   integer, intent(in)            :: Ndet, N_st, sze
+   integer(bit_kind), intent(in)  :: det_in  (N_int,2,sze)
+   complex*16 , intent(in)  :: coef_in(sze,N_st)
+   integer(bit_kind), intent(out) :: det_out (N_int,2,sze)
+   complex*16 , intent(out) :: coef_out(sze,N_st)
+   BEGIN_DOC
+   ! Determinants are sorted according to their :c:func:`det_search_key`.
+   ! Useful to accelerate the search of a random determinant in the wave
+   ! function.
+   !
+   ! /!\ The first dimension of coef_out and coef_in need to be psi_det_size
+   !
+   END_DOC
+   integer                        :: i,j,k
+   integer, allocatable           :: iorder(:)
+   integer*8, allocatable         :: bit_tmp(:)
+   integer*8, external            :: det_search_key
+
+   allocate ( iorder(Ndet), bit_tmp(Ndet) )
+
+   do i=1,Ndet
+     iorder(i) = i
+     !$DIR FORCEINLINE
+     bit_tmp(i) = det_search_key(det_in(1,1,i),N_int)
+   enddo
+   call i8sort(bit_tmp,iorder,Ndet)
+   !DIR$ IVDEP
+   do i=1,Ndet
+     do j=1,N_int
+       det_out(j,1,i) = det_in(j,1,iorder(i))
+       det_out(j,2,i) = det_in(j,2,iorder(i))
+     enddo
+     do k=1,N_st
+       coef_out(i,k) = coef_in(iorder(i),k)
+     enddo
+   enddo
+
+   deallocate(iorder, bit_tmp)
+
+end
+
+
+!==============================================================================!
+!                                                                              !
+!                             Read/write routines                              !
+!                                                                              !
+!==============================================================================!
+
+
+
+subroutine save_wavefunction_general_complex(ndet,nstates,psidet,dim_psicoef,psicoef)
+  implicit none
+  BEGIN_DOC
+  !  Save the wave function into the |EZFIO| file
+  END_DOC
+  use bitmasks
+  include 'constants.include.F'
+  integer, intent(in)            :: ndet,nstates,dim_psicoef
+  integer(bit_kind), intent(in)  :: psidet(N_int,2,ndet)
+  complex*16, intent(in)   :: psicoef(dim_psicoef,nstates)
+  integer*8, allocatable         :: psi_det_save(:,:,:)
+  complex*16, allocatable  :: psi_coef_save(:,:)
+
+  double precision               :: accu_norm
+  integer                        :: i,j,k, ndet_qp_edit
+
+  if (mpi_master) then
+    ndet_qp_edit = min(ndet,N_det_qp_edit)
+
+    call ezfio_set_determinants_N_int(N_int)
+    call ezfio_set_determinants_bit_kind(bit_kind)
+    call ezfio_set_determinants_N_det(ndet)
+    call ezfio_set_determinants_N_det_qp_edit(ndet_qp_edit)
+    call ezfio_set_determinants_n_states(nstates)
+    call ezfio_set_determinants_mo_label(mo_label)
+
+    allocate (psi_det_save(N_int,2,ndet))
+    do i=1,ndet
+      do j=1,2
+        do k=1,N_int
+          psi_det_save(k,j,i) = transfer(psidet(k,j,i),1_8)
+        enddo
+      enddo
+    enddo
+    call ezfio_set_determinants_psi_det(psi_det_save)
+    call ezfio_set_determinants_psi_det_qp_edit(psi_det_save)
+    deallocate (psi_det_save)
+
+    allocate (psi_coef_save(ndet,nstates))
+    do k=1,nstates
+      do i=1,ndet
+        psi_coef_save(i,k) = psicoef(i,k)
+      enddo
+      call normalize_complex(psi_coef_save(1,k),ndet)
+    enddo
+
+    call ezfio_set_determinants_psi_coef_complex(psi_coef_save)
+    deallocate (psi_coef_save)
+
+    allocate (psi_coef_save(ndet_qp_edit,nstates))
+    do k=1,nstates
+      do i=1,ndet_qp_edit
+        psi_coef_save(i,k) = psicoef(i,k)
+      enddo
+      call normalize_complex(psi_coef_save(1,k),ndet_qp_edit)
+    enddo
+
+    call ezfio_set_determinants_psi_coef_complex_qp_edit(psi_coef_save)
+    deallocate (psi_coef_save)
+
+    call write_int(6,ndet,'Saved determinants')
+  endif
+end
+
+
+
+subroutine save_wavefunction_specified_complex(ndet,nstates,psidet,psicoef,ndetsave,index_det_save)
+  implicit none
+  BEGIN_DOC
+  !  Save the wave function into the |EZFIO| file
+  END_DOC
+  use bitmasks
+  integer, intent(in)            :: ndet,nstates
+  integer(bit_kind), intent(in)  :: psidet(N_int,2,ndet)
+  complex*16, intent(in)   :: psicoef(ndet,nstates)
+  integer, intent(in)            :: index_det_save(ndet)
+  integer, intent(in)            :: ndetsave
+  integer*8, allocatable         :: psi_det_save(:,:,:)
+  complex*16, allocatable  :: psi_coef_save(:,:)
+  integer*8                      :: det_8(100)
+  integer(bit_kind)              :: det_bk((100*8)/bit_kind)
+  integer                        :: N_int2
+  equivalence (det_8, det_bk)
+
+  integer                        :: i,j,k, ndet_qp_edit
+
+  if (mpi_master) then
+    ndet_qp_edit = min(ndetsave,N_det_qp_edit)
+    call ezfio_set_determinants_N_int(N_int)
+    call ezfio_set_determinants_bit_kind(bit_kind)
+    call ezfio_set_determinants_N_det(ndetsave)
+    call ezfio_set_determinants_N_det_qp_edit(ndet_qp_edit)
+    call ezfio_set_determinants_n_states(nstates)
+    call ezfio_set_determinants_mo_label(mo_label)
+
+    N_int2 = (N_int*bit_kind)/8
+    allocate (psi_det_save(N_int2,2,ndetsave))
+    do i=1,ndetsave
+      do k=1,N_int
+        det_bk(k) = psidet(k,1,index_det_save(i))
+      enddo
+      do k=1,N_int2
+        psi_det_save(k,1,i) = det_8(k)
+      enddo
+      do k=1,N_int
+        det_bk(k) = psidet(k,2,index_det_save(i))
+      enddo
+      do k=1,N_int2
+        psi_det_save(k,2,i) = det_8(k)
+      enddo
+    enddo
+    call ezfio_set_determinants_psi_det(psi_det_save)
+    call ezfio_set_determinants_psi_det_qp_edit(psi_det_save)
+    deallocate (psi_det_save)
+
+    allocate (psi_coef_save(ndetsave,nstates))
+    double precision               :: accu_norm(nstates)
+    accu_norm = 0.d0
+    do k=1,nstates
+      do i=1,ndetsave
+        accu_norm(k) = accu_norm(k) + cdabs(psicoef(index_det_save(i),k) * psicoef(index_det_save(i),k))
+        psi_coef_save(i,k) = psicoef(index_det_save(i),k)
+      enddo
+    enddo
+    do k = 1, nstates
+      accu_norm(k) = 1.d0/dsqrt(accu_norm(k))
+    enddo
+    do k=1,nstates
+      do i=1,ndetsave
+        psi_coef_save(i,k) = psi_coef_save(i,k) * accu_norm(k)
+      enddo
+    enddo
+
+    call ezfio_set_determinants_psi_coef_complex(psi_coef_save)
+    deallocate (psi_coef_save)
+
+    allocate (psi_coef_save(ndet_qp_edit,nstates))
+    accu_norm = 0.d0
+    do k=1,nstates
+      do i=1,ndet_qp_edit
+        accu_norm(k) = accu_norm(k) + cdabs(psicoef(index_det_save(i),k) * psicoef(index_det_save(i),k))
+        psi_coef_save(i,k) = psicoef(index_det_save(i),k)
+      enddo
+    enddo
+    do k = 1, nstates
+      accu_norm(k) = 1.d0/dsqrt(accu_norm(k))
+    enddo
+    do k=1,nstates
+      do i=1,ndet_qp_edit
+        psi_coef_save(i,k) = psi_coef_save(i,k) * accu_norm(k)
+      enddo
+    enddo
+    !TODO: should this be psi_coef_complex_qp_edit?
+    call ezfio_set_determinants_psi_coef_complex(psi_coef_save)
+    deallocate (psi_coef_save)
+
+    call write_int(6,ndet,'Saved determinants')
+  endif
+end
+

src/determinants/energy.irp.f

@@ -21,11 +21,19 @@ BEGIN_PROVIDER [ double precision, barycentric_electronic_energy, (N_states) ]
 
  barycentric_electronic_energy(:) = 0.d0
 
+ if (is_complex) then
+   do istate=1,N_states
+     do i=1,N_det
+       barycentric_electronic_energy(istate) += cdabs(psi_coef_complex(i,istate)*psi_coef_complex(i,istate))*diagonal_H_matrix_on_psi_det(i)
+     enddo
+   enddo
+ else
  do istate=1,N_states
    do i=1,N_det
      barycentric_electronic_energy(istate) += psi_coef(i,istate)*psi_coef(i,istate)*diagonal_H_matrix_on_psi_det(i)
    enddo
  enddo
+ endif
 
 END_PROVIDER
 

src/determinants/fock_diag.irp.f

@@ -29,12 +29,12 @@ subroutine build_fock_tmp(fock_diag_tmp,det_ref,Nint)
     call debug_det(det_ref,N_int)
     stop -1
   endif
-
+  
   ! Occupied MOs
   do ii=1,elec_alpha_num
     i = occ(ii,1)
-    fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_one_e_integrals(i,i)
-    E0 = E0 + mo_one_e_integrals(i,i)
+    fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_one_e_integrals_diag(i)
+    E0 = E0 + mo_one_e_integrals_diag(i)
     do jj=1,elec_alpha_num
       j = occ(jj,1)
       if (i==j) cycle
@@ -49,8 +49,8 @@ subroutine build_fock_tmp(fock_diag_tmp,det_ref,Nint)
   enddo
   do ii=1,elec_beta_num
     i = occ(ii,2)
-    fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_one_e_integrals(i,i)
-    E0 = E0 + mo_one_e_integrals(i,i)
+    fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_one_e_integrals_diag(i)
+    E0 = E0 + mo_one_e_integrals_diag(i)
     do jj=1,elec_beta_num
       j = occ(jj,2)
       if (i==j) cycle
@@ -66,7 +66,7 @@ subroutine build_fock_tmp(fock_diag_tmp,det_ref,Nint)
   ! Virtual MOs
   do i=1,mo_num
     if (fock_diag_tmp(1,i) /= 0.d0) cycle
-    fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_one_e_integrals(i,i)
+    fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_one_e_integrals_diag(i)
     do jj=1,elec_alpha_num
       j = occ(jj,1)
       fock_diag_tmp(1,i) = fock_diag_tmp(1,i) + mo_two_e_integrals_jj_anti(i,j)
@@ -78,7 +78,7 @@ subroutine build_fock_tmp(fock_diag_tmp,det_ref,Nint)
   enddo
   do i=1,mo_num
     if (fock_diag_tmp(2,i) /= 0.d0) cycle
-    fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_one_e_integrals(i,i)
+    fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_one_e_integrals_diag(i)
     do jj=1,elec_beta_num
       j = occ(jj,2)
       fock_diag_tmp(2,i) = fock_diag_tmp(2,i) + mo_two_e_integrals_jj_anti(i,j)

src/determinants/h_apply.irp.f

@@ -6,6 +6,7 @@ type H_apply_buffer_type
   integer                        :: sze
   integer(bit_kind), pointer     :: det(:,:,:)
   double precision , pointer     :: coef(:,:)
+  complex*16 , pointer           :: coef_complex(:,:)
   double precision , pointer     :: e2(:,:)
 end type H_apply_buffer_type
 
@@ -26,17 +27,22 @@ type(H_apply_buffer_type), pointer :: H_apply_buffer(:)
     allocate(H_apply_buffer(0:nproc-1))
     iproc = 0
     !$OMP PARALLEL PRIVATE(iproc) DEFAULT(NONE)  &
-    !$OMP SHARED(H_apply_buffer,N_int,sze,N_states,H_apply_buffer_lock)
+    !$OMP SHARED(H_apply_buffer,N_int,sze,N_states,H_apply_buffer_lock,is_complex)
     !$   iproc = omp_get_thread_num()
     H_apply_buffer(iproc)%N_det = 0
     H_apply_buffer(iproc)%sze = sze
     allocate (                                                       &
         H_apply_buffer(iproc)%det(N_int,2,sze),                      &
-        H_apply_buffer(iproc)%coef(sze,N_states),                    &
         H_apply_buffer(iproc)%e2(sze,N_states)                       &
         )
+    if (is_complex) then
+      allocate(H_apply_buffer(iproc)%coef_complex(sze,N_states))
+      H_apply_buffer(iproc)%coef_complex = (0.d0,0.d0)
+    else
+      allocate(H_apply_buffer(iproc)%coef(sze,N_states))
+      H_apply_buffer(iproc)%coef = 0.d0
+    endif
     H_apply_buffer(iproc)%det  = 0_bit_kind
-    H_apply_buffer(iproc)%coef = 0.d0
     H_apply_buffer(iproc)%e2   = 0.d0
     call omp_init_lock(H_apply_buffer_lock(1,iproc))
     !$OMP END PARALLEL
@@ -59,6 +65,7 @@ subroutine resize_H_apply_buffer(new_size,iproc)
   integer, intent(in)            :: new_size, iproc
   integer(bit_kind), pointer     :: buffer_det(:,:,:)
   double precision,  pointer     :: buffer_coef(:,:)
+  complex*16,  pointer           :: buffer_coef_complex(:,:)
   double precision,  pointer     :: buffer_e2(:,:)
   integer                        :: i,j,k
   integer                        :: Ndet
@@ -74,9 +81,14 @@ subroutine resize_H_apply_buffer(new_size,iproc)
   ASSERT (iproc < nproc)
 
   allocate ( buffer_det(N_int,2,new_size),                           &
-      buffer_coef(new_size,N_states),                                &
       buffer_e2(new_size,N_states) )
-  buffer_coef = 0.d0
+  if (is_complex) then
+    allocate(buffer_coef_complex(new_size,N_states))
+    buffer_coef_complex = (0.d0,0.d0)
+  else
+    allocate(buffer_coef(new_size,N_states))
+    buffer_coef = 0.d0
+  endif
   buffer_e2 = 0.d0
   do i=1,min(new_size,H_apply_buffer(iproc)%N_det)
     do k=1,N_int
@@ -89,6 +101,15 @@ subroutine resize_H_apply_buffer(new_size,iproc)
   deallocate(H_apply_buffer(iproc)%det)
   H_apply_buffer(iproc)%det => buffer_det
 
+  if (is_complex) then
+    do k=1,N_states
+      do i=1,min(new_size,H_apply_buffer(iproc)%N_det)
+        buffer_coef_complex(i,k) = H_apply_buffer(iproc)%coef_complex(i,k)
+      enddo
+    enddo
+    deallocate(H_apply_buffer(iproc)%coef_complex)
+    H_apply_buffer(iproc)%coef_complex => buffer_coef_complex
+  else
   do k=1,N_states
     do i=1,min(new_size,H_apply_buffer(iproc)%N_det)
       buffer_coef(i,k) = H_apply_buffer(iproc)%coef(i,k)
@@ -96,6 +117,7 @@ subroutine resize_H_apply_buffer(new_size,iproc)
   enddo
   deallocate(H_apply_buffer(iproc)%coef)
   H_apply_buffer(iproc)%coef => buffer_coef
+  endif
 
   do k=1,N_states
     do i=1,min(new_size,H_apply_buffer(iproc)%N_det)
@@ -119,6 +141,7 @@ subroutine copy_H_apply_buffer_to_wf
   END_DOC
   integer(bit_kind), allocatable :: buffer_det(:,:,:)
   double precision, allocatable  :: buffer_coef(:,:)
+  complex*16, allocatable        :: buffer_coef_complex(:,:)
   integer                        :: i,j,k
   integer                        :: N_det_old
 
@@ -128,7 +151,12 @@ subroutine copy_H_apply_buffer_to_wf
   ASSERT (N_int > 0)
   ASSERT (N_det > 0)
 
-  allocate ( buffer_det(N_int,2,N_det), buffer_coef(N_det,N_states) )
+  allocate ( buffer_det(N_int,2,N_det))
+  if (is_complex) then
+    allocate(buffer_coef_complex(N_det,N_states))
+  else
+    allocate(buffer_coef(N_det,N_states))
+  endif
 
   ! Backup determinants
   j=0
@@ -142,6 +170,17 @@ subroutine copy_H_apply_buffer_to_wf
   N_det_old = j
 
   ! Backup coefficients
+  if (is_complex) then
+    do k=1,N_states
+      j=0
+      do i=1,N_det
+        if (pruned(i)) cycle  ! Pruned determinants
+        j += 1
+        buffer_coef_complex(j,k) = psi_coef_complex(i,k)
+      enddo
+      ASSERT ( j == N_det_old )
+    enddo
+  else
   do k=1,N_states
     j=0
     do i=1,N_det
@@ -151,6 +190,7 @@ subroutine copy_H_apply_buffer_to_wf
     enddo
     ASSERT ( j == N_det_old )
   enddo
+  endif
 
   ! Update N_det
   N_det = N_det_old
@@ -170,13 +210,56 @@ subroutine copy_H_apply_buffer_to_wf
     ASSERT (sum(popcnt(psi_det(:,1,i))) == elec_alpha_num)
     ASSERT (sum(popcnt(psi_det(:,2,i))) == elec_beta_num )
   enddo
+  if (is_complex) then
+    do k=1,N_states
+      do i=1,N_det_old
+        psi_coef_complex(i,k) = buffer_coef_complex(i,k)
+      enddo
+    enddo
+  else
   do k=1,N_states
     do i=1,N_det_old
       psi_coef(i,k) = buffer_coef(i,k)
     enddo
   enddo
+  endif
 
   ! Copy new buffers
+  logical :: found_duplicates
+
+  if (is_complex) then
+    !$OMP PARALLEL DEFAULT(SHARED)                                     &
+        !$OMP PRIVATE(j,k,i) FIRSTPRIVATE(N_det_old)                   &
+        !$OMP SHARED(N_int,H_apply_buffer,psi_det,psi_coef_complex,N_states,psi_det_size)
+    j=0
+    !$ j=omp_get_thread_num()
+    do k=0,j-1
+      N_det_old += H_apply_buffer(k)%N_det
+    enddo
+    do i=1,H_apply_buffer(j)%N_det
+      do k=1,N_int
+        psi_det(k,1,i+N_det_old) = H_apply_buffer(j)%det(k,1,i)
+        psi_det(k,2,i+N_det_old) = H_apply_buffer(j)%det(k,2,i)
+      enddo
+      ASSERT (sum(popcnt(psi_det(:,1,i+N_det_old))) == elec_alpha_num)
+      ASSERT (sum(popcnt(psi_det(:,2,i+N_det_old))) == elec_beta_num )
+    enddo
+    do k=1,N_states
+      do i=1,H_apply_buffer(j)%N_det
+        psi_coef_complex(i+N_det_old,k) = H_apply_buffer(j)%coef_complex(i,k)
+      enddo
+    enddo
+    !$OMP BARRIER
+    H_apply_buffer(j)%N_det = 0
+    !$OMP END PARALLEL
+    SOFT_TOUCH N_det psi_det psi_coef_complex
+
+    call remove_duplicates_in_psi_det(found_duplicates)
+    do k=1,N_states
+      call normalize(psi_coef_complex(1,k),N_det)
+    enddo
+    SOFT_TOUCH N_det psi_det psi_coef_complex
+  else
 
   !$OMP PARALLEL DEFAULT(SHARED)                                     &
       !$OMP PRIVATE(j,k,i) FIRSTPRIVATE(N_det_old)                   &
@@ -204,13 +287,13 @@ subroutine copy_H_apply_buffer_to_wf
   !$OMP END PARALLEL
   SOFT_TOUCH N_det psi_det psi_coef
 
-  logical :: found_duplicates
   call remove_duplicates_in_psi_det(found_duplicates)
   do k=1,N_states
     call normalize(psi_coef(1,k),N_det)
   enddo
   SOFT_TOUCH N_det psi_det psi_coef
 
+  endif
 end
 
 subroutine remove_duplicates_in_psi_det(found_duplicates)
@@ -275,6 +358,29 @@ subroutine remove_duplicates_in_psi_det(found_duplicates)
   !$OMP END DO
   !$OMP END PARALLEL
 
+  if (is_complex) then
+    if (found_duplicates) then
+      k=0
+      do i=1,N_det
+        if (.not.duplicate(i)) then
+          k += 1
+          psi_det(:,:,k) = psi_det_sorted_bit (:,:,i)
+          psi_coef_complex(k,:)  = psi_coef_sorted_bit_complex(i,:)
+        else
+          if (sum(cdabs(psi_coef_sorted_bit_complex(i,:))) /= 0.d0 ) then
+            psi_coef_complex(k,:)  = psi_coef_sorted_bit_complex(i,:)
+          endif
+        endif
+      enddo
+      N_det = k
+      psi_det_sorted_bit(:,:,1:N_det) = psi_det(:,:,1:N_det)
+      psi_coef_sorted_bit_complex(1:N_det,:) = psi_coef_complex(1:N_det,:)
+      TOUCH N_det psi_det psi_coef_complex psi_det_sorted_bit psi_coef_sorted_bit_complex c0_weight
+    endif
+    psi_det = psi_det_sorted
+    psi_coef_complex = psi_coef_sorted_complex
+    SOFT_TOUCH psi_det psi_coef_complex psi_det_sorted_bit psi_coef_sorted_bit_complex
+  else
   if (found_duplicates) then
     k=0
     do i=1,N_det
@@ -296,6 +402,7 @@ subroutine remove_duplicates_in_psi_det(found_duplicates)
   psi_det = psi_det_sorted
   psi_coef = psi_coef_sorted
   SOFT_TOUCH psi_det psi_coef psi_det_sorted_bit psi_coef_sorted_bit
+  endif
   deallocate (duplicate,bit_tmp)
 end
 
@@ -329,11 +436,19 @@ subroutine fill_H_apply_buffer_no_selection(n_selected,det_buffer,Nint,iproc)
     ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i+H_apply_buffer(iproc)%N_det)) )== elec_alpha_num)
     ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,2,i+H_apply_buffer(iproc)%N_det))) == elec_beta_num)
   enddo
+  if (is_complex) then
+    do j=1,N_states
+      do i=1,N_selected
+        H_apply_buffer(iproc)%coef_complex(i+H_apply_buffer(iproc)%N_det,j) = (0.d0,0.d0)
+      enddo
+    enddo
+  else
   do j=1,N_states
     do i=1,N_selected
       H_apply_buffer(iproc)%coef(i+H_apply_buffer(iproc)%N_det,j) = 0.d0
     enddo
   enddo
+  endif
   H_apply_buffer(iproc)%N_det = new_size
   do i=1,H_apply_buffer(iproc)%N_det
     ASSERT (sum(popcnt(H_apply_buffer(iproc)%det(:,1,i)) )== elec_alpha_num)
@@ -341,4 +456,3 @@ subroutine fill_H_apply_buffer_no_selection(n_selected,det_buffer,Nint,iproc)
   enddo
   call omp_unset_lock(H_apply_buffer_lock(1,iproc))
 end
-

src/determinants/h_apply_nozmq.template.f

@@ -17,8 +17,11 @@ subroutine $subroutine($params_main)
   double precision, allocatable  :: fock_diag_tmp(:,:)
 
   $initialization
+  if (is_complex) then
+    PROVIDE H_apply_buffer_allocated mo_two_e_integrals_in_map psi_det_generators psi_coef_generators_complex
+  else
   PROVIDE H_apply_buffer_allocated mo_two_e_integrals_in_map psi_det_generators psi_coef_generators
-
+  endif
 
   call wall_time(wall_0)
 

src/determinants/occ_pattern.irp.f

@@ -401,12 +401,21 @@ BEGIN_PROVIDER [ double precision, weight_occ_pattern, (N_occ_pattern,N_states)
  END_DOC
  integer :: i,j,k
  weight_occ_pattern = 0.d0
+ if (is_complex) then
+ do i=1,N_det
+  j = det_to_occ_pattern(i)
+  do k=1,N_states
+    weight_occ_pattern(j,k) += cdabs(psi_coef_complex(i,k) * psi_coef_complex(i,k))
+  enddo
+ enddo
+ else
  do i=1,N_det
   j = det_to_occ_pattern(i)
   do k=1,N_states
     weight_occ_pattern(j,k) += psi_coef(i,k) * psi_coef(i,k)
   enddo
  enddo
+ endif
 END_PROVIDER
 
 BEGIN_PROVIDER [ double precision, weight_occ_pattern_average, (N_occ_pattern) ]
@@ -416,12 +425,21 @@ BEGIN_PROVIDER [ double precision, weight_occ_pattern_average, (N_occ_pattern) ]
  END_DOC
  integer :: i,j,k
  weight_occ_pattern_average(:) = 0.d0
+ if (is_complex) then
+  do i=1,N_det
+   j = det_to_occ_pattern(i)
+   do k=1,N_states
+     weight_occ_pattern_average(j) += cdabs(psi_coef_complex(i,k) * psi_coef_complex(i,k)) * state_average_weight(k)
+   enddo
+  enddo
+ else
  do i=1,N_det
   j = det_to_occ_pattern(i)
   do k=1,N_states
     weight_occ_pattern_average(j) += psi_coef(i,k) * psi_coef(i,k) * state_average_weight(k)
   enddo
  enddo
+ endif
 END_PROVIDER
 
  BEGIN_PROVIDER [ integer(bit_kind), psi_occ_pattern_sorted, (N_int,2,N_occ_pattern) ]
@@ -495,7 +513,7 @@ subroutine make_s2_eigenfunction
       N_det_new += 1
       det_buffer(:,:,N_det_new) = d(:,:,j)
       if (N_det_new == bufsze) then
-        call fill_H_apply_buffer_no_selection(bufsze,det_buffer,N_int,ithread)
+        call fill_h_apply_buffer_no_selection(bufsze,det_buffer,N_int,ithread)
         N_det_new = 0
       endif
     enddo
@@ -510,8 +528,12 @@ subroutine make_s2_eigenfunction
   !$OMP END PARALLEL
 
   if (update) then
-    call copy_H_apply_buffer_to_wf
+    call copy_h_apply_buffer_to_wf
+    if (is_complex) then
+      TOUCH N_det psi_coef_complex psi_det psi_occ_pattern N_occ_pattern
+    else
     TOUCH N_det psi_coef psi_det psi_occ_pattern N_occ_pattern
+    endif
   endif
   call write_time(6)
 

src/determinants/psi_cas.irp.f

@@ -150,7 +150,20 @@ END_PROVIDER
  double precision :: hij,norm,u_dot_v
   psi_cas_energy = 0.d0
 
-
+  if (is_complex) then
+    complex*16 :: hij_c
+    do k = 1, N_states
+      norm = 0.d0
+      do i = 1, N_det_cas_complex
+        norm += cdabs(psi_cas_coef_complex(i,k) * psi_cas_coef_complex(i,k))
+        do j = 1, N_det_cas_complex
+          !TODO: accum imag parts to ensure that sum is zero?
+          psi_cas_energy(k) += dble(dconjg(psi_cas_coef_complex(i,k)) * psi_cas_coef_complex(j,k) * H_matrix_cas_complex(i,j))
+        enddo
+      enddo
+      psi_cas_energy(k) = psi_cas_energy(k) /norm
+    enddo
+  else
   do k = 1, N_states
    norm = 0.d0
    do i = 1, N_det_cas
@@ -161,6 +174,7 @@ END_PROVIDER
    enddo
    psi_cas_energy(k) = psi_cas_energy(k) /norm
   enddo
+  endif
 
 END_PROVIDER
 

src/determinants/psi_cas_cplx.irp.f

@@ -0,0 +1,145 @@
+use bitmasks
+
+ BEGIN_PROVIDER [ integer(bit_kind), psi_cas_complex, (N_int,2,psi_det_size) ]
+&BEGIN_PROVIDER [ complex*16, psi_cas_coef_complex,  (psi_det_size,n_states) ]
+&BEGIN_PROVIDER [ integer, idx_cas_complex, (psi_det_size) ]
+&BEGIN_PROVIDER [ integer, N_det_cas_complex ]
+  implicit none
+  BEGIN_DOC
+  ! |CAS| wave function, defined from the application of the |CAS| bitmask on the
+  ! determinants. idx_cas gives the indice of the |CAS| determinant in psi_det.
+  END_DOC
+  integer                        :: i, k, l
+  logical                        :: good
+  n_det_cas_complex = 0
+  do i=1,N_det
+    do l = 1, N_states
+     psi_cas_coef_complex(i,l) = (0.d0,0.d0)
+    enddo
+    good = .True.
+    do k=1,N_int
+      good = good .and. (                                          &
+          iand(not(act_bitmask(k,1)), psi_det(k,1,i)) ==         &
+          iand(not(act_bitmask(k,1)), hf_bitmask(k,1)) ) .and. (  &
+          iand(not(act_bitmask(k,2)), psi_det(k,2,i)) ==         &
+          iand(not(act_bitmask(k,2)), hf_bitmask(k,2)) )
+    enddo
+    if (good) then
+      exit
+    endif
+    if (good) then
+      n_det_cas_complex = n_det_cas_complex+1
+      do k=1,N_int
+        psi_cas_complex(k,1,n_det_cas_complex) = psi_det(k,1,i)
+        psi_cas_complex(k,2,n_det_cas_complex) = psi_det(k,2,i)
+      enddo
+      idx_cas(n_det_cas_complex) = i
+      do k=1,N_states
+        psi_cas_coef_complex(n_det_cas_complex,k) = psi_coef_complex(i,k)
+      enddo
+    endif
+  enddo
+  call write_int(6,n_det_cas_complex, 'Number of determinants in the CAS')
+
+END_PROVIDER
+
+
+ BEGIN_PROVIDER [ integer(bit_kind), psi_cas_sorted_bit_complex, (N_int,2,psi_det_size) ]
+&BEGIN_PROVIDER [ complex*16, psi_cas_coef_sorted_bit_complex, (psi_det_size,N_states) ]
+ implicit none
+ BEGIN_DOC
+ ! |CAS| determinants sorted to accelerate the search of a random determinant in the wave
+ ! function.
+ END_DOC
+ call sort_dets_by_det_search_key_complex(n_det_cas_complex, psi_cas_complex, psi_cas_coef_complex, size(psi_cas_coef_complex,1), &
+     psi_cas_sorted_bit_complex, psi_cas_coef_sorted_bit_complex, N_states)
+
+END_PROVIDER
+
+
+
+ BEGIN_PROVIDER [ integer(bit_kind), psi_non_cas_complex,  (N_int,2,psi_det_size) ]
+&BEGIN_PROVIDER [ complex*16, psi_non_cas_coef_complex, (psi_det_size,n_states) ]
+&BEGIN_PROVIDER [ integer, idx_non_cas_complex,  (psi_det_size) ]
+&BEGIN_PROVIDER [ integer, N_det_non_cas_complex ]
+ implicit none
+ BEGIN_DOC
+  ! Set of determinants which are not part of the |CAS|, defined from the application
+  ! of the |CAS| bitmask on the determinants.
+  ! idx_non_cas gives the indice of the determinant in psi_det.
+ END_DOC
+ integer                        :: i_non_cas,j,k
+ integer                        :: degree
+ logical                        :: in_cas
+ i_non_cas =0
+ do k=1,N_det
+   in_cas = .False.
+   do j=1,N_det_cas_complex
+     call get_excitation_degree(psi_cas_complex(1,1,j), psi_det(1,1,k), degree, N_int)
+     if (degree == 0) then
+       in_cas = .True.
+       exit
+     endif
+   enddo
+   if (.not.in_cas) then
+     double precision :: hij
+     i_non_cas += 1
+     do j=1,N_int
+       psi_non_cas_complex(j,1,i_non_cas) = psi_det(j,1,k)
+       psi_non_cas_complex(j,2,i_non_cas) = psi_det(j,2,k)
+     enddo
+     do j=1,N_states
+       psi_non_cas_coef_complex(i_non_cas,j) = psi_coef_complex(k,j)
+     enddo
+     idx_non_cas_complex(i_non_cas) = k
+   endif
+ enddo
+ N_det_non_cas_complex = i_non_cas
+END_PROVIDER
+
+ BEGIN_PROVIDER [ integer(bit_kind), psi_non_cas_sorted_bit_complex, (N_int,2,psi_det_size) ]
+&BEGIN_PROVIDER [ complex*16, psi_non_cas_coef_sorted_bit_complex, (psi_det_size,N_states) ]
+ implicit none
+ BEGIN_DOC
+ ! |CAS| determinants sorted to accelerate the search of a random determinant in the wave
+ ! function.
+ END_DOC
+ !TODO: should this be n_det_non_cas_complex?
+ call sort_dets_by_det_search_key_complex(N_det_cas_complex, psi_non_cas_complex, psi_non_cas_coef_complex, size(psi_non_cas_coef_complex,1), &
+     psi_non_cas_sorted_bit_complex, psi_non_cas_coef_sorted_bit_complex, N_states)
+
+END_PROVIDER
+
+
+BEGIN_PROVIDER [complex*16, H_matrix_cas_complex, (N_det_cas_complex,N_det_cas_complex)]
+ implicit none
+ integer :: i,j
+ complex*16 :: hij
+  do i = 1, N_det_cas_complex
+   do j = 1, N_det_cas_complex
+    call i_h_j_complex(psi_cas_complex(1,1,i),psi_cas_complex(1,1,j),N_int,hij)
+    H_matrix_cas_complex(i,j) = hij
+   enddo
+  enddo
+END_PROVIDER
+
+ BEGIN_PROVIDER [complex*16, psi_coef_cas_diagonalized_complex, (N_det_cas_complex,N_states)]
+&BEGIN_PROVIDER [double precision, psi_cas_energy_diagonalized_complex, (N_states)]
+ implicit none
+ integer :: i,j
+  double precision, allocatable  :: eigenvalues(:)
+  complex*16, allocatable  :: eigenvectors(:,:)
+  allocate (eigenvectors(size(H_matrix_cas,1),N_det_cas))
+  allocate (eigenvalues(N_det_cas))
+  call lapack_diag_complex(eigenvalues,eigenvectors,                       &
+      H_matrix_cas_complex,size(H_matrix_cas_complex,1),N_det_cas_complex)
+  do i = 1, N_states
+   psi_cas_energy_diagonalized_complex(i) = eigenvalues(i)
+   do j = 1, N_det_cas_complex
+    psi_coef_cas_diagonalized_complex(j,i) = eigenvectors(j,i)
+   enddo
+  enddo
+
+
+ END_PROVIDER
+

src/determinants/psi_energy_mono_elec.irp.f

@@ -9,7 +9,26 @@
 ! computed using the :c:data:`one_e_dm_mo_alpha` +
 ! :c:data:`one_e_dm_mo_beta` and :c:data:`mo_one_e_integrals`
   END_DOC
+  double precision :: accu
   psi_energy_h_core = 0.d0
+  if (is_complex) then
+    do i = 1, N_states
+      do j = 1, mo_num
+        do k = 1, mo_num
+          psi_energy_h_core(i) += dble(mo_one_e_integrals_complex(k,j) * &
+                      (one_e_dm_mo_alpha_complex(j,k,i) + one_e_dm_mo_beta_complex(j,k,i)))
+        enddo
+      enddo
+    enddo
+    do i = 1, N_states
+      accu = 0.d0
+      do j = 1, mo_num
+        accu += dble(one_e_dm_mo_alpha_complex(j,j,i) + one_e_dm_mo_beta_complex(j,j,i))
+      enddo
+      accu = (elec_alpha_num + elec_beta_num ) / accu
+      psi_energy_h_core(i) = psi_energy_h_core(i) * accu
+    enddo
+  else
   do i = 1, N_states
    do j = 1, mo_num
     do k = 1, mo_num
@@ -17,7 +36,6 @@
     enddo
    enddo
   enddo
- double precision :: accu
  do i = 1, N_states
   accu = 0.d0
   do j = 1, mo_num
@@ -26,4 +44,5 @@
   accu = (elec_alpha_num + elec_beta_num ) / accu
   psi_energy_h_core(i) = psi_energy_h_core(i) * accu
  enddo
+ endif
 END_PROVIDER

src/determinants/ref_bitmask.irp.f

@@ -6,6 +6,7 @@
 &BEGIN_PROVIDER [ double precision, ref_bitmask_energy_ab ]
 &BEGIN_PROVIDER [ double precision, ref_bitmask_energy_bb ]
 &BEGIN_PROVIDER [ double precision, ref_bitmask_energy_aa ]
+&BEGIN_PROVIDER [ double precision, ref_bitmask_energy_with_nucl_rep ]
 
   use bitmasks
   implicit none
@@ -27,15 +28,15 @@
   ref_bitmask_two_e_energy = 0.d0
 
   do i = 1, elec_beta_num
-    ref_bitmask_energy += mo_one_e_integrals(occ(i,1),occ(i,1)) + mo_one_e_integrals(occ(i,2),occ(i,2))
-    ref_bitmask_kinetic_energy += mo_kinetic_integrals(occ(i,1),occ(i,1)) + mo_kinetic_integrals(occ(i,2),occ(i,2))
-    ref_bitmask_n_e_energy += mo_integrals_n_e(occ(i,1),occ(i,1)) + mo_integrals_n_e(occ(i,2),occ(i,2))
+    ref_bitmask_energy += mo_one_e_integrals_diag(occ(i,1)) + mo_one_e_integrals_diag(occ(i,2))
+    ref_bitmask_kinetic_energy += mo_kinetic_integrals_diag(occ(i,1)) + mo_kinetic_integrals_diag(occ(i,2))
+    ref_bitmask_n_e_energy += mo_integrals_n_e_diag(occ(i,1)) + mo_integrals_n_e_diag(occ(i,2))
   enddo
 
   do i = elec_beta_num+1,elec_alpha_num
-    ref_bitmask_energy += mo_one_e_integrals(occ(i,1),occ(i,1))
-    ref_bitmask_kinetic_energy += mo_kinetic_integrals(occ(i,1),occ(i,1))
-    ref_bitmask_n_e_energy += mo_integrals_n_e(occ(i,1),occ(i,1))
+    ref_bitmask_energy += mo_one_e_integrals_diag(occ(i,1))
+    ref_bitmask_kinetic_energy += mo_kinetic_integrals_diag(occ(i,1))
+    ref_bitmask_n_e_energy += mo_integrals_n_e_diag(occ(i,1))
   enddo
 
   do j= 1, elec_alpha_num
@@ -80,7 +81,7 @@
  enddo
  ref_bitmask_energy_bb = ref_bitmask_energy_bb * 0.5d0
 
-
+ ref_bitmask_energy_with_nucl_rep = ref_bitmask_energy + nuclear_repulsion 
 
 END_PROVIDER
 

src/determinants/s2.irp.f

@@ -98,7 +98,11 @@ BEGIN_PROVIDER [ double precision, s2_values, (N_states) ]
 ! array of the averaged values of the S^2 operator on the various states
  END_DOC
  integer :: i
+ if (is_complex) then
+    call u_0_S2_u_0_complex(s2_values,psi_coef_complex,n_det,psi_det,N_int,N_states,psi_det_size)
+ else
  call u_0_S2_u_0(s2_values,psi_coef,n_det,psi_det,N_int,N_states,psi_det_size)
+ endif
 
 END_PROVIDER
 

src/determinants/s2_cplx.irp.f

@@ -0,0 +1,288 @@
+subroutine u_0_S2_u_0_complex(e_0,u_0,n,keys_tmp,Nint,N_st,sze_8)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Computes e_0 = <u_0|S2|u_0>/<u_0|u_0>
+  !
+  ! n : number of determinants
+  !
+  END_DOC
+  integer, intent(in)            :: n,Nint, N_st, sze_8
+  double precision, intent(out)  :: e_0(N_st)
+  complex*16, intent(in)   :: u_0(sze_8,N_st)
+  integer(bit_kind),intent(in)   :: keys_tmp(Nint,2,n)
+
+  complex*16, allocatable  :: v_0(:,:)
+  double precision               :: u_dot_u_complex
+  complex*16                     :: u_dot_v_complex
+  integer :: i,j
+  allocate (v_0(sze_8,N_st))
+
+  call s2_u_0_nstates_complex(v_0,u_0,n,keys_tmp,Nint,N_st,sze_8)
+  do i=1,N_st
+    e_0(i) = dble(u_dot_v_complex(u_0(1,i),v_0(1,i),n))/u_dot_u_complex(u_0(1,i),n) + S_z2_Sz
+  enddo
+end
+
+
+
+subroutine S2_u_0_complex(v_0,u_0,n,keys_tmp,Nint)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Computes v_0 = S^2|u_0>
+  !
+  ! n : number of determinants
+  !
+  END_DOC
+  integer, intent(in)            :: n,Nint
+  complex*16, intent(out)  :: v_0(n)
+  complex*16, intent(in)   :: u_0(n)
+  integer(bit_kind),intent(in)   :: keys_tmp(Nint,2,n)
+  call s2_u_0_nstates_complex(v_0,u_0,n,keys_tmp,Nint,1,n)
+end
+
+subroutine S2_u_0_nstates_complex(v_0,u_0,n,keys_tmp,Nint,N_st,sze_8)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Computes v_0  = S^2|u_0>
+  !
+  ! n : number of determinants
+  !
+  END_DOC
+  integer, intent(in)            :: N_st,n,Nint, sze_8
+  complex*16, intent(out)  :: v_0(sze_8,N_st)
+  complex*16, intent(in)   :: u_0(sze_8,N_st)
+  integer(bit_kind),intent(in)   :: keys_tmp(Nint,2,n)
+  double precision               :: s2_tmp
+  complex*16, allocatable  :: vt(:,:)
+  integer                        :: i,j,k,l, jj,ii
+  integer                        :: i0, j0
+
+  integer, allocatable           :: shortcut(:,:), sort_idx(:,:)
+  integer(bit_kind), allocatable :: sorted(:,:,:), version(:,:,:)
+  integer(bit_kind)              :: sorted_i(Nint)
+
+  integer                        :: sh, sh2, ni, exa, ext, org_i, org_j, endi, istate
+
+
+  ASSERT (Nint > 0)
+  ASSERT (Nint == N_int)
+  ASSERT (n>0)
+  PROVIDE ref_bitmask_energy
+
+  allocate (shortcut(0:n+1,2), sort_idx(n,2), sorted(Nint,n,2), version(Nint,n,2))
+  v_0 = (0.d0,0.d0)
+
+  call sort_dets_ab_v(keys_tmp, sorted(1,1,1), sort_idx(1,1), shortcut(0,1), version(1,1,1), n, Nint)
+  call sort_dets_ba_v(keys_tmp, sorted(1,1,2), sort_idx(1,2), shortcut(0,2), version(1,1,2), n, Nint)
+
+  !$OMP PARALLEL DEFAULT(NONE)                                       &
+      !$OMP PRIVATE(i,s2_tmp,j,k,jj,vt,ii,sh,sh2,ni,exa,ext,org_i,org_j,endi,sorted_i,istate)&
+      !$OMP SHARED(n,u_0,keys_tmp,Nint,v_0,sorted,shortcut,sort_idx,version,N_st,sze_8)
+  allocate(vt(sze_8,N_st))
+  vt = (0.d0,0.d0)
+
+  do sh=1,shortcut(0,1)
+    !$OMP DO SCHEDULE(static,1)
+    do sh2=sh,shortcut(0,1)
+      exa = 0
+      do ni=1,Nint
+        exa = exa + popcnt(xor(version(ni,sh,1), version(ni,sh2,1)))
+      end do
+      if(exa > 2) then
+        cycle
+      end if
+
+      do i=shortcut(sh,1),shortcut(sh+1,1)-1
+        org_i = sort_idx(i,1)
+        if(sh==sh2) then
+          endi = i-1
+        else
+          endi = shortcut(sh2+1,1)-1
+        end if
+        do ni=1,Nint
+          sorted_i(ni) = sorted(ni,i,1)
+        enddo
+
+        do j=shortcut(sh2,1),endi
+          org_j = sort_idx(j,1)
+          ext = exa
+          do ni=1,Nint
+            ext = ext + popcnt(xor(sorted_i(ni), sorted(ni,j,1)))
+          end do
+          if(ext <= 4) then
+            call get_s2(keys_tmp(1,1,org_i),keys_tmp(1,1,org_j),Nint,s2_tmp)
+            do istate=1,N_st
+              vt (org_i,istate) = vt (org_i,istate) + s2_tmp*u_0(org_j,istate)
+              vt (org_j,istate) = vt (org_j,istate) + s2_tmp*u_0(org_i,istate)
+            enddo
+          endif
+        enddo
+      enddo
+    enddo
+    !$OMP END DO NOWAIT
+  enddo
+
+  do sh=1,shortcut(0,2)
+    !$OMP DO
+    do i=shortcut(sh,2),shortcut(sh+1,2)-1
+      org_i = sort_idx(i,2)
+      do j=shortcut(sh,2),i-1
+        org_j = sort_idx(j,2)
+        ext = 0
+        do ni=1,Nint
+          ext = ext + popcnt(xor(sorted(ni,i,2), sorted(ni,j,2)))
+        end do
+        if(ext == 4) then
+          call get_s2(keys_tmp(1,1,org_i),keys_tmp(1,1,org_j),Nint,s2_tmp)
+          do istate=1,N_st
+            vt (org_i,istate) = vt (org_i,istate) + s2_tmp*u_0(org_j,istate)
+            vt (org_j,istate) = vt (org_j,istate) + s2_tmp*u_0(org_i,istate)
+          enddo
+        end if
+      end do
+    end do
+    !$OMP END DO NOWAIT
+  enddo
+  !$OMP BARRIER
+
+  do istate=1,N_st
+    do i=n,1,-1
+      !$OMP ATOMIC
+      v_0(i,istate) = v_0(i,istate) + vt(i,istate)
+    enddo
+  enddo
+
+  deallocate(vt)
+  !$OMP END PARALLEL
+
+  do i=1,n
+    call get_s2(keys_tmp(1,1,i),keys_tmp(1,1,i),Nint,s2_tmp)
+    do istate=1,N_st
+      v_0(i,istate) += s2_tmp * u_0(i,istate)
+    enddo
+  enddo
+
+  deallocate (shortcut, sort_idx, sorted, version)
+end
+
+
+
+
+
+
+
+subroutine get_uJ_s2_uI_complex(psi_keys_tmp,psi_coefs_tmp,n,nmax_coefs,nmax_keys,s2,nstates)
+  !todo: modify/implement for complex
+  print*,irp_here,' not implemented for complex'
+  stop -1
+!  implicit none
+!  use bitmasks
+!  integer, intent(in)            :: n,nmax_coefs,nmax_keys,nstates
+!  integer(bit_kind), intent(in)  :: psi_keys_tmp(N_int,2,nmax_keys)
+!  complex*16, intent(in)   :: psi_coefs_tmp(nmax_coefs,nstates)
+!  complex*16, intent(out)  :: s2(nstates,nstates)
+!  double precision               :: s2_tmp
+!  complex*16                     :: accu
+!  integer                        :: i,j,l,jj,ll,kk
+!  integer, allocatable           :: idx(:)
+!  BEGIN_DOC
+!  ! returns the matrix elements of S^2 "s2(i,j)" between the "nstates" states
+!  ! psi_coefs_tmp(:,i) and psi_coefs_tmp(:,j)
+!  END_DOC
+!  s2 = (0.d0,0.d0)
+!  do ll = 1, nstates
+!    do jj = 1, nstates
+!      accu = (0.d0,0.d0)
+!      !$OMP PARALLEL DEFAULT(NONE)                                   &
+!          !$OMP PRIVATE (i,j,kk,idx,s2_tmp)                          &
+!          !$OMP SHARED (ll,jj,psi_keys_tmp,psi_coefs_tmp,N_int,n,nstates)&
+!          !$OMP REDUCTION(+:accu)
+!      allocate(idx(0:n))
+!      !$OMP DO SCHEDULE(dynamic)
+!      do i = n,1,-1   ! Better OMP scheduling
+!        call get_s2(psi_keys_tmp(1,1,i),psi_keys_tmp(1,1,i),N_int,s2_tmp)
+!        accu += dconjg(psi_coefs_tmp(i,ll)) * s2_tmp * psi_coefs_tmp(i,jj)
+!        call filter_connected(psi_keys_tmp,psi_keys_tmp(1,1,i),N_int,i-1,idx)
+!        do kk=1,idx(0)
+!          j = idx(kk)
+!          call get_s2(psi_keys_tmp(1,1,i),psi_keys_tmp(1,1,j),N_int,s2_tmp)
+!          accu += dconjg(psi_coefs_tmp(i,ll)) * s2_tmp * psi_coefs_tmp(j,jj) + psi_coefs_tmp(i,jj) * s2_tmp * psi_coefs_tmp(j,ll)
+!        enddo
+!      enddo
+!      !$OMP END DO
+!      deallocate(idx)
+!      !$OMP END PARALLEL
+!      s2(ll,jj) += accu
+!    enddo
+!  enddo
+!  do i = 1, nstates
+!    do j =i+1,nstates
+!      accu = 0.5d0 * (s2(i,j) + s2(j,i))
+!      s2(i,j) = accu
+!      s2(j,i) = accu
+!    enddo
+!  enddo
+end
+
+
+subroutine i_S2_psi_minilist_complex(key,keys,idx_key,N_minilist,coef,Nint,Ndet,Ndet_max,Nstate,i_S2_psi_array)
+  !todo: modify/implement for complex
+  print*,irp_here,' not implemented for complex'
+  stop -1
+!  use bitmasks
+!  implicit none
+!  integer, intent(in)            :: Nint, Ndet,Ndet_max,Nstate,idx_key(Ndet), N_minilist
+!  integer(bit_kind), intent(in)  :: keys(Nint,2,Ndet)
+!  integer(bit_kind), intent(in)  :: key(Nint,2)
+!  double precision, intent(in)   :: coef(Ndet_max,Nstate)
+!  double precision, intent(out)  :: i_S2_psi_array(Nstate)
+!
+!  integer                        :: i, ii,j, i_in_key, i_in_coef
+!  double precision               :: phase
+!  integer                        :: exc(0:2,2,2)
+!  double precision               :: s2ij
+!  integer                        :: idx(0:Ndet)
+!  BEGIN_DOC
+!! Computes $\langle i|S^2|\Psi \rangle = \sum_J c_J \langle i|S^2|J \rangle$.
+!!
+!! Uses filter_connected_i_H_psi0 to get all the $|J\rangle$ to which $|i\rangle$
+!! is connected. The $|J\rangle$ are searched in short pre-computed lists.
+!  END_DOC
+!
+!  ASSERT (Nint > 0)
+!  ASSERT (N_int == Nint)
+!  ASSERT (Nstate > 0)
+!  ASSERT (Ndet > 0)
+!  ASSERT (Ndet_max >= Ndet)
+!  i_S2_psi_array = 0.d0
+!
+!  call filter_connected_i_H_psi0(keys,key,Nint,N_minilist,idx)
+!  if (Nstate == 1) then
+!
+!    do ii=1,idx(0)
+!      i_in_key = idx(ii)
+!      i_in_coef = idx_key(idx(ii))
+!      !DIR$ FORCEINLINE
+!      call get_s2(keys(1,1,i_in_key),key,Nint,s2ij)
+!      ! TODO : Cache misses
+!      i_S2_psi_array(1) = i_S2_psi_array(1) + coef(i_in_coef,1)*s2ij
+!    enddo
+!
+!  else
+!
+!    do ii=1,idx(0)
+!      i_in_key = idx(ii)
+!      i_in_coef = idx_key(idx(ii))
+!      !DIR$ FORCEINLINE
+!      call get_s2(keys(1,1,i_in_key),key,Nint,s2ij)
+!      do j = 1, Nstate
+!        i_S2_psi_array(j) = i_S2_psi_array(j) + coef(i_in_coef,j)*s2ij
+!      enddo
+!    enddo
+!
+!  endif
+!
+end

src/determinants/single_excitation_two_e.irp.f

@@ -133,4 +133,138 @@ BEGIN_PROVIDER [double precision, fock_wee_closed_shell, (mo_num, mo_num) ]
 
 END_PROVIDER
 
+subroutine single_excitation_wee_complex(det_1,det_2,h,p,spin,phase,hij)
+ use bitmasks
+ implicit none
+ integer,intent(in) :: h,p,spin
+ double precision, intent(in)  :: phase
+ integer(bit_kind), intent(in) :: det_1(N_int,2), det_2(N_int,2)
+ complex*16, intent(out) :: hij
+ integer(bit_kind) :: differences(N_int,2)
+ integer(bit_kind) :: hole(N_int,2)
+ integer(bit_kind) :: partcl(N_int,2)
+ integer :: occ_hole(N_int*bit_kind_size,2)
+ integer :: occ_partcl(N_int*bit_kind_size,2)
+ integer :: n_occ_ab_hole(2),n_occ_ab_partcl(2)
+ integer :: i0,i
+ do i = 1, N_int
+  differences(i,1) = xor(det_1(i,1),ref_closed_shell_bitmask(i,1))
+  differences(i,2) = xor(det_1(i,2),ref_closed_shell_bitmask(i,2))
+  hole(i,1) = iand(differences(i,1),ref_closed_shell_bitmask(i,1))
+  hole(i,2) = iand(differences(i,2),ref_closed_shell_bitmask(i,2))
+  partcl(i,1) = iand(differences(i,1),det_1(i,1))
+  partcl(i,2) = iand(differences(i,2),det_1(i,2))
+ enddo
+ call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, N_int)
+ call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, N_int)
+ hij = fock_wee_closed_shell_complex(h,p)
+ ! holes :: direct terms
+ do i0 = 1, n_occ_ab_hole(1)
+  i = occ_hole(i0,1)
+  hij -= big_array_coulomb_integrals_complex(i,h,p) ! get_mo_two_e_integral_schwartz(h,i,p,i,mo_integrals_map)
+ enddo
+ do i0 = 1, n_occ_ab_hole(2)
+  i = occ_hole(i0,2)
+  hij -= big_array_coulomb_integrals_complex(i,h,p) !get_mo_two_e_integral_schwartz(h,i,p,i,mo_integrals_map)
+ enddo
+
+ ! holes :: exchange terms
+ do i0 = 1, n_occ_ab_hole(spin)
+  i = occ_hole(i0,spin)
+  hij += big_array_exchange_integrals_complex(i,h,p) ! get_mo_two_e_integral_schwartz(h,i,i,p,mo_integrals_map)
+ enddo
+
+ ! particles :: direct terms
+ do i0 = 1, n_occ_ab_partcl(1)
+  i = occ_partcl(i0,1)
+  hij += big_array_coulomb_integrals_complex(i,h,p)!get_mo_two_e_integral_schwartz(h,i,p,i,mo_integrals_map)
+ enddo
+ do i0 = 1, n_occ_ab_partcl(2)
+  i = occ_partcl(i0,2)
+  hij += big_array_coulomb_integrals_complex(i,h,p) !get_mo_two_e_integral_schwartz(h,i,p,i,mo_integrals_map)
+ enddo
+
+ ! particles :: exchange terms
+ do i0 = 1, n_occ_ab_partcl(spin)
+  i = occ_partcl(i0,spin)
+  hij -= big_array_exchange_integrals_complex(i,h,p)!get_mo_two_e_integral_schwartz(h,i,i,p,mo_integrals_map)
+ enddo
+ hij = hij * phase
+
+end
+
+
+BEGIN_PROVIDER [complex*16, fock_wee_closed_shell_complex, (mo_num, mo_num) ]
+ implicit none
+ integer :: i0,j0,i,j,k0,k
+ integer :: n_occ_ab(2)
+ integer :: occ(N_int*bit_kind_size,2)
+ integer :: n_occ_ab_virt(2)
+ integer :: occ_virt(N_int*bit_kind_size,2)
+ integer(bit_kind) :: key_test(N_int)
+ integer(bit_kind) :: key_virt(N_int,2)
+ complex*16 :: accu
+
+ call bitstring_to_list_ab(ref_closed_shell_bitmask, occ, n_occ_ab, N_int)
+ do i = 1, N_int
+  key_virt(i,1) = full_ijkl_bitmask(i)
+  key_virt(i,2) = full_ijkl_bitmask(i)
+  key_virt(i,1) = xor(key_virt(i,1),ref_closed_shell_bitmask(i,1))
+  key_virt(i,2) = xor(key_virt(i,2),ref_closed_shell_bitmask(i,2))
+ enddo
+ complex*16 :: array_coulomb(mo_num),array_exchange(mo_num)
+ call bitstring_to_list_ab(key_virt, occ_virt, n_occ_ab_virt, N_int)
+ ! docc ---> virt single excitations
+ do i0 = 1,  n_occ_ab(1)
+  i=occ(i0,1)
+  do j0 = 1, n_occ_ab_virt(1)
+   j = occ_virt(j0,1)
+   call get_mo_two_e_integrals_coulomb_ii_complex(i,j,mo_num,array_coulomb,mo_integrals_map,mo_integrals_map_2)
+   call get_mo_two_e_integrals_exch_ii_complex(i,j,mo_num,array_exchange,mo_integrals_map,mo_integrals_map_2)
+   accu = (0.d0,0.d0)
+   do k0 = 1, n_occ_ab(1)
+    k = occ(k0,1)
+    accu += 2.d0 * array_coulomb(k) - array_exchange(k)
+   enddo
+   fock_wee_closed_shell_complex(i,j) = accu
+   fock_wee_closed_shell_complex(j,i) = dconjg(accu)
+  enddo
+ enddo
+
+ ! virt ---> virt single excitations
+ do i0 = 1,  n_occ_ab_virt(1)
+  i=occ_virt(i0,1)
+  do j0 = 1, n_occ_ab_virt(1)
+   j = occ_virt(j0,1)
+   call get_mo_two_e_integrals_coulomb_ii_complex(i,j,mo_num,array_coulomb,mo_integrals_map,mo_integrals_map_2)
+   call get_mo_two_e_integrals_exch_ii_complex(i,j,mo_num,array_exchange,mo_integrals_map,mo_integrals_map_2)
+   accu = (0.d0,0.d0)
+   do k0 = 1, n_occ_ab(1)
+    k = occ(k0,1)
+    accu += 2.d0 * array_coulomb(k) - array_exchange(k)
+   enddo
+   fock_wee_closed_shell_complex(i,j) = accu
+   fock_wee_closed_shell_complex(j,i) = dconjg(accu)
+  enddo
+ enddo
+
+ ! docc ---> docc single excitations
+ do i0 = 1,  n_occ_ab(1)
+  i=occ(i0,1)
+  do j0 = 1, n_occ_ab(1)
+   j = occ(j0,1)
+   call get_mo_two_e_integrals_coulomb_ii_complex(i,j,mo_num,array_coulomb,mo_integrals_map,mo_integrals_map_2)
+   call get_mo_two_e_integrals_exch_ii_complex(i,j,mo_num,array_exchange,mo_integrals_map,mo_integrals_map_2)
+   accu = (0.d0,0.d0)
+   do k0 = 1, n_occ_ab(1)
+    k = occ(k0,1)
+    accu += 2.d0 * array_coulomb(k) - array_exchange(k)
+   enddo
+   fock_wee_closed_shell_complex(i,j) = accu
+   fock_wee_closed_shell_complex(j,i) = dconjg(accu)
+  enddo
+ enddo
+
+END_PROVIDER
+
 

src/determinants/single_excitations.irp.f

@@ -1,7 +1,7 @@
   use bitmasks
 BEGIN_PROVIDER [integer(bit_kind), ref_closed_shell_bitmask, (N_int,2)]
  implicit none
- integer :: i,i0
+ integer :: i,i0,k
  integer :: n_occ_ab(2)
  integer :: occ(N_int*bit_kind_size,2)
  call bitstring_to_list_ab(ref_bitmask, occ, n_occ_ab, N_int)
@@ -10,16 +10,24 @@ BEGIN_PROVIDER [integer(bit_kind), ref_closed_shell_bitmask, (N_int,2)]
   ref_closed_shell_bitmask(i,1) = ref_bitmask(i,1)
   ref_closed_shell_bitmask(i,2) = ref_bitmask(i,2)
  enddo
- do i0 = elec_beta_num+1, elec_alpha_num
-   i=occ(i0,1)
-   call clear_bit_to_integer(i,ref_closed_shell_bitmask(1,1),N_int)
- enddo
-
-
+ if (is_complex) then
+   !todo: check this
+   do k=1,kpt_num
+     call bitstring_to_list_ab(ref_bitmask_kpts(1,1,k),occ,n_occ_ab,N_int)
+     do i0=elec_beta_num_kpts(k)+1,elec_alpha_num_kpts(k)
+       i=occ(i0,1)
+       call clear_bit_to_integer(i,ref_closed_shell_bitmask(1,1),N_int)
+     enddo
+   enddo
+ else
+   do i0 = elec_beta_num+1, elec_alpha_num
+     i=occ(i0,1)
+     call clear_bit_to_integer(i,ref_closed_shell_bitmask(1,1),N_int)
+   enddo
+ endif
 END_PROVIDER
 
-
-BEGIN_PROVIDER [double precision, fock_operator_closed_shell_ref_bitmask, (mo_num, mo_num) ]
+BEGIN_PROVIDER [double precision, fock_op_cshell_ref_bitmask, (mo_num, mo_num) ]
  implicit none
  integer :: i0,j0,i,j,k0,k
  integer :: n_occ_ab(2)
@@ -52,8 +60,8 @@ BEGIN_PROVIDER [double precision, fock_operator_closed_shell_ref_bitmask, (mo_nu
     k = occ(k0,1)
     accu += 2.d0 * array_coulomb(k) - array_exchange(k)
    enddo
-   fock_operator_closed_shell_ref_bitmask(i,j) = accu + mo_one_e_integrals(i,j)
-   fock_operator_closed_shell_ref_bitmask(j,i) = accu + mo_one_e_integrals(i,j)
+   fock_op_cshell_ref_bitmask(i,j) = accu + mo_one_e_integrals(i,j)
+   fock_op_cshell_ref_bitmask(j,i) = accu + mo_one_e_integrals(i,j)
   enddo
  enddo
 
@@ -69,8 +77,8 @@ BEGIN_PROVIDER [double precision, fock_operator_closed_shell_ref_bitmask, (mo_nu
     k = occ(k0,1)
     accu += 2.d0 * array_coulomb(k) - array_exchange(k)
    enddo
-   fock_operator_closed_shell_ref_bitmask(i,j) = accu+ mo_one_e_integrals(i,j)
-   fock_operator_closed_shell_ref_bitmask(j,i) = accu+ mo_one_e_integrals(i,j)
+   fock_op_cshell_ref_bitmask(i,j) = accu+ mo_one_e_integrals(i,j)
+   fock_op_cshell_ref_bitmask(j,i) = accu+ mo_one_e_integrals(i,j)
   enddo
  enddo
 
@@ -86,8 +94,8 @@ BEGIN_PROVIDER [double precision, fock_operator_closed_shell_ref_bitmask, (mo_nu
     k = occ(k0,1)
     accu += 2.d0 * array_coulomb(k) - array_exchange(k)
    enddo
-   fock_operator_closed_shell_ref_bitmask(i,j) = accu+ mo_one_e_integrals(i,j)
-   fock_operator_closed_shell_ref_bitmask(j,i) = accu+ mo_one_e_integrals(i,j)
+   fock_op_cshell_ref_bitmask(i,j) = accu+ mo_one_e_integrals(i,j)
+   fock_op_cshell_ref_bitmask(j,i) = accu+ mo_one_e_integrals(i,j)
   enddo
  enddo
  deallocate(array_coulomb,array_exchange)
@@ -123,7 +131,7 @@ subroutine get_single_excitation_from_fock(det_1,det_2,h,p,spin,phase,hij)
  enddo
  call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, N_int)
  call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, N_int)
- hij = fock_operator_closed_shell_ref_bitmask(h,p)
+ hij = fock_op_cshell_ref_bitmask(h,p)
  ! holes :: direct terms
  do i0 = 1, n_occ_ab_hole(1)
   i = occ_hole(i0,1)
@@ -159,3 +167,349 @@ subroutine get_single_excitation_from_fock(det_1,det_2,h,p,spin,phase,hij)
 
 end
 
+!============================================!
+!                                            !
+!                 complex                    !
+!                                            !
+!============================================!
+
+BEGIN_PROVIDER [complex*16, fock_op_cshell_ref_bitmask_cplx, (mo_num, mo_num) ]
+ implicit none
+ integer :: i0,j0,i,j,k0,k
+ integer :: n_occ_ab(2)
+ integer :: occ(N_int*bit_kind_size,2)
+ integer :: n_occ_ab_virt(2)
+ integer :: occ_virt(N_int*bit_kind_size,2)
+ integer(bit_kind) :: key_test(N_int)
+ integer(bit_kind) :: key_virt(N_int,2)
+ complex*16 :: accu
+
+ call bitstring_to_list_ab(ref_closed_shell_bitmask, occ, n_occ_ab, N_int)
+ do i = 1, N_int
+  key_virt(i,1) = full_ijkl_bitmask(i)
+  key_virt(i,2) = full_ijkl_bitmask(i)
+  key_virt(i,1) = xor(key_virt(i,1),ref_closed_shell_bitmask(i,1))
+  key_virt(i,2) = xor(key_virt(i,2),ref_closed_shell_bitmask(i,2))
+ enddo
+ complex*16, allocatable :: array_coulomb(:),array_exchange(:)
+ allocate (array_coulomb(mo_num),array_exchange(mo_num))
+ call bitstring_to_list_ab(key_virt, occ_virt, n_occ_ab_virt, N_int)
+ ! docc ---> virt single excitations
+ do i0 = 1,  n_occ_ab(1)
+  i=occ(i0,1)
+  do j0 = 1, n_occ_ab_virt(1)
+   j = occ_virt(j0,1)
+   ! <ia|ja>
+   call get_mo_two_e_integrals_coulomb_ii_complex(i,j,mo_num,array_coulomb,mo_integrals_map,mo_integrals_map_2)
+   ! <ia|aj>
+   call get_mo_two_e_integrals_exch_ii_complex(i,j,mo_num,array_exchange,mo_integrals_map,mo_integrals_map_2)
+   accu = (0.d0,0.d0)
+   do k0 = 1, n_occ_ab(1)
+    k = occ(k0,1)
+    accu += 2.d0 * array_coulomb(k) - array_exchange(k)
+   enddo
+   fock_op_cshell_ref_bitmask_cplx(i,j) = accu + mo_one_e_integrals_complex(i,j)
+   !fock_op_cshell_ref_bitmask_cplx(j,i) = dconjg(accu) + mo_one_e_integrals_complex(j,i)
+   fock_op_cshell_ref_bitmask_cplx(j,i) = dconjg(fock_op_cshell_ref_bitmask_cplx(i,j))
+  enddo
+ enddo
+
+ ! virt ---> virt single excitations
+ do i0 = 1,  n_occ_ab_virt(1)
+  i=occ_virt(i0,1)
+  do j0 = 1, n_occ_ab_virt(1)
+   j = occ_virt(j0,1)
+   call get_mo_two_e_integrals_coulomb_ii_complex(i,j,mo_num,array_coulomb,mo_integrals_map,mo_integrals_map_2)
+   call get_mo_two_e_integrals_exch_ii_complex(i,j,mo_num,array_exchange,mo_integrals_map,mo_integrals_map_2)
+   accu = (0.d0,0.d0)
+   do k0 = 1, n_occ_ab(1)
+    k = occ(k0,1)
+    accu += 2.d0 * array_coulomb(k) - array_exchange(k)
+   enddo
+   fock_op_cshell_ref_bitmask_cplx(i,j) = accu+ mo_one_e_integrals_complex(i,j)
+   fock_op_cshell_ref_bitmask_cplx(j,i) = dconjg(accu)+ mo_one_e_integrals_complex(j,i)
+  enddo
+ enddo
+
+ ! docc ---> docc single excitations
+ do i0 = 1,  n_occ_ab(1)
+  i=occ(i0,1)
+  do j0 = 1, n_occ_ab(1)
+   j = occ(j0,1)
+   call get_mo_two_e_integrals_coulomb_ii_complex(i,j,mo_num,array_coulomb,mo_integrals_map,mo_integrals_map_2)
+   call get_mo_two_e_integrals_exch_ii_complex(i,j,mo_num,array_exchange,mo_integrals_map,mo_integrals_map_2)
+   accu = (0.d0,0.d0)
+   do k0 = 1, n_occ_ab(1)
+    k = occ(k0,1)
+    accu += 2.d0 * array_coulomb(k) - array_exchange(k)
+   enddo
+   fock_op_cshell_ref_bitmask_cplx(i,j) = accu+ mo_one_e_integrals_complex(i,j)
+   fock_op_cshell_ref_bitmask_cplx(j,i) = dconjg(accu)+ mo_one_e_integrals_complex(j,i)
+  enddo
+ enddo
+ deallocate(array_coulomb,array_exchange)
+
+END_PROVIDER
+
+subroutine get_single_excitation_from_fock_complex(det_1,det_2,h,p,spin,phase,hij)
+ use bitmasks
+ implicit none
+ integer,intent(in) :: h,p,spin
+ double precision, intent(in)  :: phase
+ integer(bit_kind), intent(in) :: det_1(N_int,2), det_2(N_int,2)
+ complex*16, intent(out) :: hij
+ integer(bit_kind) :: differences(N_int,2)
+ integer(bit_kind) :: hole(N_int,2)
+ integer(bit_kind) :: partcl(N_int,2)
+ integer :: occ_hole(N_int*bit_kind_size,2)
+ integer :: occ_partcl(N_int*bit_kind_size,2)
+ integer :: n_occ_ab_hole(2),n_occ_ab_partcl(2)
+ integer :: i0,i
+ complex*16 :: buffer_c(mo_num),buffer_x(mo_num)
+ do i=1, mo_num
+   buffer_c(i) = big_array_coulomb_integrals_complex(i,h,p)
+   buffer_x(i) = big_array_exchange_integrals_complex(i,h,p)
+ enddo
+ do i = 1, N_int
+  differences(i,1) = xor(det_1(i,1),ref_closed_shell_bitmask(i,1))
+  differences(i,2) = xor(det_1(i,2),ref_closed_shell_bitmask(i,2))
+  hole(i,1) = iand(differences(i,1),ref_closed_shell_bitmask(i,1))
+  hole(i,2) = iand(differences(i,2),ref_closed_shell_bitmask(i,2))
+  partcl(i,1) = iand(differences(i,1),det_1(i,1))
+  partcl(i,2) = iand(differences(i,2),det_1(i,2))
+ enddo
+ call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, N_int)
+ call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, N_int)
+ hij = fock_op_cshell_ref_bitmask_cplx(h,p)
+ ! holes :: direct terms
+ do i0 = 1, n_occ_ab_hole(1)
+  i = occ_hole(i0,1)
+  hij -= buffer_c(i)
+ enddo
+ do i0 = 1, n_occ_ab_hole(2)
+  i = occ_hole(i0,2)
+  hij -= buffer_c(i)
+ enddo
+
+ ! holes :: exchange terms
+ do i0 = 1, n_occ_ab_hole(spin)
+  i = occ_hole(i0,spin)
+  hij += buffer_x(i)
+ enddo
+
+ ! particles :: direct terms
+ do i0 = 1, n_occ_ab_partcl(1)
+  i = occ_partcl(i0,1)
+  hij += buffer_c(i)
+ enddo
+ do i0 = 1, n_occ_ab_partcl(2)
+  i = occ_partcl(i0,2)
+  hij += buffer_c(i)
+ enddo
+
+ ! particles :: exchange terms
+ do i0 = 1, n_occ_ab_partcl(spin)
+  i = occ_partcl(i0,spin)
+  hij -= buffer_x(i)
+ enddo
+ hij = hij * phase
+
+end
+
+!============================================!
+!                                            !
+!                    kpts                    !
+!                                            !
+!============================================!
+
+BEGIN_PROVIDER [integer(bit_kind), ref_closed_shell_bitmask_kpts, (N_int,2,kpt_num)]
+ implicit none
+ integer :: i,k
+ do k = 1, kpt_num
+   do i = 1, N_int
+     ref_closed_shell_bitmask_kpts(i,1,k) = iand(ref_closed_shell_bitmask(i,1),kpts_bitmask(i,k))
+     ref_closed_shell_bitmask_kpts(i,2,k) = iand(ref_closed_shell_bitmask(i,2),kpts_bitmask(i,k))
+   enddo
+ enddo
+END_PROVIDER
+
+BEGIN_PROVIDER [complex*16, fock_op_cshell_ref_bitmask_kpts, (mo_num_per_kpt, mo_num_per_kpt,kpt_num) ]
+ implicit none
+ integer :: i0,j0,i,j,k0,k,kblock,kvirt
+ integer :: i_i, i_j, i_k, kocc
+ integer :: n_occ_ab(2,kpt_num)
+ integer :: occ(N_int*bit_kind_size,2,kpt_num)
+ integer :: n_occ_ab_virt(2)
+ integer :: occ_virt(N_int*bit_kind_size,2)
+ integer(bit_kind) :: key_test(N_int)
+ integer(bit_kind) :: key_virt(N_int,2)
+ complex*16 :: accu
+ complex*16, allocatable :: array_coulomb(:),array_exchange(:)
+
+ do kblock = 1,kpt_num
+   call bitstring_to_list_ab(ref_closed_shell_bitmask_kpts(1,1,kblock), &
+                            occ(1,1,kblock), n_occ_ab(1,kblock), N_int)
+ enddo
+ allocate (array_coulomb(mo_num_per_kpt),array_exchange(mo_num_per_kpt))
+ do kblock = 1,kpt_num
+   ! get virt orbs for this kpt
+   do i = 1, N_int
+     key_virt(i,1) = iand(full_ijkl_bitmask(i),kpts_bitmask(i,kblock))
+     key_virt(i,2) = iand(full_ijkl_bitmask(i),kpts_bitmask(i,kblock))
+     key_virt(i,1) = xor(key_virt(i,1),ref_closed_shell_bitmask_kpts(i,1,kblock))
+     key_virt(i,2) = xor(key_virt(i,2),ref_closed_shell_bitmask_kpts(i,2,kblock))
+   enddo
+   call bitstring_to_list_ab(key_virt, occ_virt, n_occ_ab_virt, N_int)
+   ! docc ---> virt single excitations
+   do i0 = 1,  n_occ_ab(1,kblock)
+    i=occ(i0,1,kblock)
+    i_i = mod(i-1,mo_num_per_kpt)+1
+    do j0 = 1, n_occ_ab_virt(1)
+     j = occ_virt(j0,1)
+     i_j = mod(j-1,mo_num_per_kpt)+1
+     accu = (0.d0,0.d0)
+     do kocc = 1,kpt_num
+      ! <ia|ja>
+      array_coulomb(1:mo_num_per_kpt) = big_array_coulomb_integrals_kpts(1:mo_num_per_kpt,kocc,i_i,i_j,kblock)
+      ! <ia|aj>
+      array_exchange(1:mo_num_per_kpt) = big_array_exchange_integrals_kpts(1:mo_num_per_kpt,kocc,i_i,i_j,kblock)
+      do k0 = 1, n_occ_ab(1,kocc)
+       k = occ(k0,1,kocc)
+       i_k = mod(k-1,mo_num_per_kpt)+1
+       accu += 2.d0 * array_coulomb(i_k) - array_exchange(i_k)
+      enddo
+     enddo
+     fock_op_cshell_ref_bitmask_kpts(i_i,i_j,kblock) = accu + mo_one_e_integrals_kpts(i_i,i_j,kblock)
+     !fock_op_cshell_ref_bitmask_cplx(j,i) = dconjg(accu) + mo_one_e_integrals_complex(j,i)
+     fock_op_cshell_ref_bitmask_kpts(i_j,i_i,kblock) = dconjg(fock_op_cshell_ref_bitmask_kpts(i_i,i_j,kblock))
+    enddo
+   enddo
+  
+   ! virt ---> virt single excitations
+   do i0 = 1,  n_occ_ab_virt(1)
+    i=occ_virt(i0,1)
+    i_i = mod(i-1,mo_num_per_kpt)+1
+    do j0 = 1, n_occ_ab_virt(1)
+     j = occ_virt(j0,1)
+     i_j = mod(j-1,mo_num_per_kpt)+1
+     accu = (0.d0,0.d0)
+     do kocc = 1,kpt_num
+      array_coulomb(1:mo_num_per_kpt) = big_array_coulomb_integrals_kpts(1:mo_num_per_kpt,kocc,i_i,i_j,kblock)
+      array_exchange(1:mo_num_per_kpt) = big_array_exchange_integrals_kpts(1:mo_num_per_kpt,kocc,i_i,i_j,kblock)
+      do k0 = 1, n_occ_ab(1,kocc)
+       k = occ(k0,1,kocc)
+       i_k = mod(k-1,mo_num_per_kpt)+1
+       accu += 2.d0 * array_coulomb(i_k) - array_exchange(i_k)
+      enddo
+     enddo
+     fock_op_cshell_ref_bitmask_kpts(i_i,i_j,kblock) = accu + mo_one_e_integrals_kpts(i_i,i_j,kblock)
+     fock_op_cshell_ref_bitmask_kpts(i_j,i_i,kblock) = dconjg(fock_op_cshell_ref_bitmask_kpts(i_i,i_j,kblock))
+    enddo
+   enddo
+  
+   ! docc ---> docc single excitations
+   do i0 = 1,  n_occ_ab(1,kblock)
+    i=occ(i0,1,kblock)
+    i_i = mod(i-1,mo_num_per_kpt)+1
+    do j0 = 1, n_occ_ab(1,kblock)
+     j = occ(j0,1,kblock)
+     i_j = mod(j-1,mo_num_per_kpt)+1
+     accu = (0.d0,0.d0)
+     do kocc = 1,kpt_num
+      array_coulomb(1:mo_num_per_kpt) = big_array_coulomb_integrals_kpts(1:mo_num_per_kpt,kocc,i_i,i_j,kblock)
+      array_exchange(1:mo_num_per_kpt) = big_array_exchange_integrals_kpts(1:mo_num_per_kpt,kocc,i_i,i_j,kblock)
+      do k0 = 1, n_occ_ab(1,kocc)
+       k = occ(k0,1,kocc)
+       i_k = mod(k-1,mo_num_per_kpt)+1
+       accu += 2.d0 * array_coulomb(i_k) - array_exchange(i_k)
+      enddo
+     enddo
+     fock_op_cshell_ref_bitmask_kpts(i_i,i_j,kblock) = accu + mo_one_e_integrals_kpts(i_i,i_j,kblock)
+     fock_op_cshell_ref_bitmask_kpts(i_j,i_i,kblock) = dconjg(fock_op_cshell_ref_bitmask_kpts(i_i,i_j,kblock))
+    enddo
+   enddo
+  enddo
+ deallocate(array_coulomb,array_exchange)
+
+END_PROVIDER
+
+subroutine get_single_excitation_from_fock_kpts(det_1,det_2,ih,ip,spin,phase,hij)
+  use bitmasks
+  !called by i_h_j{,_s2,_single_spin}_complex
+  ! ih, ip are indices in total mo list (not per kpt)
+  implicit none
+  integer,intent(in) :: ih,ip,spin
+  double precision, intent(in)  :: phase
+  integer(bit_kind), intent(in) :: det_1(N_int,2), det_2(N_int,2)
+  complex*16, intent(out) :: hij
+  integer(bit_kind) :: differences(N_int,2)
+  integer(bit_kind) :: hole(N_int,2)
+  integer(bit_kind) :: partcl(N_int,2)
+  integer :: occ_hole(N_int*bit_kind_size,2)
+  integer :: occ_partcl(N_int*bit_kind_size,2)
+  integer :: n_occ_ab_hole(2),n_occ_ab_partcl(2)
+  integer :: i0,i,h,p
+  integer :: ki,khp
+  complex*16 :: buffer_c(mo_num_per_kpt),buffer_x(mo_num_per_kpt)
+  khp = (ip-1)/mo_num_per_kpt+1
+  p = mod(ip-1,mo_num_per_kpt)+1
+  h = mod(ih-1,mo_num_per_kpt)+1
+  !todo: omp kpts
+  do ki=1,kpt_num
+    do i=1, mo_num_per_kpt
+      !<hi|pi>
+      buffer_c(i) = big_array_coulomb_integrals_kpts(i,ki,h,p,khp)
+      !<hi|ip>
+      buffer_x(i) = big_array_exchange_integrals_kpts(i,ki,h,p,khp)
+    enddo
+    do i = 1, N_int
+      !holes in ref, not in det1
+      !part in det1, not in ref
+      differences(i,1) = iand(xor(det_1(i,1),ref_closed_shell_bitmask(i,1)),kpts_bitmask(i,ki))
+      differences(i,2) = iand(xor(det_1(i,2),ref_closed_shell_bitmask(i,2)),kpts_bitmask(i,ki))
+      !differences(i,1) = xor(det_1(i,1),ref_closed_shell_bitmask_kpts(i,1,ki))
+      !differences(i,2) = xor(det_1(i,2),ref_closed_shell_bitmask_kpts(i,2,ki))
+      hole(i,1) = iand(differences(i,1),ref_closed_shell_bitmask_kpts(i,1,ki))
+      hole(i,2) = iand(differences(i,2),ref_closed_shell_bitmask_kpts(i,2,ki))
+      partcl(i,1) = iand(differences(i,1),det_1(i,1))
+      partcl(i,2) = iand(differences(i,2),det_1(i,2))
+    enddo
+    call bitstring_to_list_ab(hole, occ_hole, n_occ_ab_hole, N_int)
+    call bitstring_to_list_ab(partcl, occ_partcl, n_occ_ab_partcl, N_int)
+    hij = fock_op_cshell_ref_bitmask_kpts(h,p,khp)
+    ! holes :: direct terms
+    do i0 = 1, n_occ_ab_hole(1)
+      i = occ_hole(i0,1) - (ki-1)*mo_num_per_kpt
+      hij -= buffer_c(i)
+    enddo
+    do i0 = 1, n_occ_ab_hole(2)
+      i = occ_hole(i0,2) - (ki-1)*mo_num_per_kpt
+      hij -= buffer_c(i)
+    enddo
+   
+    ! holes :: exchange terms
+    do i0 = 1, n_occ_ab_hole(spin)
+      i = occ_hole(i0,spin) - (ki-1)*mo_num_per_kpt
+      hij += buffer_x(i)
+    enddo
+   
+    ! particles :: direct terms
+    do i0 = 1, n_occ_ab_partcl(1)
+      i = occ_partcl(i0,1) - (ki-1)*mo_num_per_kpt
+      hij += buffer_c(i)
+    enddo
+    do i0 = 1, n_occ_ab_partcl(2)
+      i = occ_partcl(i0,2) - (ki-1)*mo_num_per_kpt
+      hij += buffer_c(i)
+    enddo
+   
+    ! particles :: exchange terms
+    do i0 = 1, n_occ_ab_partcl(spin)
+      i = occ_partcl(i0,spin) - (ki-1)*mo_num_per_kpt
+      hij -= buffer_x(i)
+    enddo
+  enddo
+  hij = hij * phase
+
+end
+

src/determinants/slater_rules.irp.f

@@ -1581,8 +1581,6 @@ subroutine get_excitation_degree_vector(key1,key2,degree,Nint,sze,idx)
 end
 
 
-
-
 double precision function diag_H_mat_elem_fock(det_ref,det_pert,fock_diag_tmp,Nint)
   use bitmasks
   implicit none
@@ -1745,7 +1743,7 @@ subroutine a_operator(iorb,ispin,key,hjj,Nint,na,nb)
   call bitstring_to_list_ab(key, occ, tmp, Nint)
   na = na-1
 
-  hjj = hjj - mo_one_e_integrals(iorb,iorb)
+  hjj = hjj - mo_one_e_integrals_diag(iorb)
 
   ! Same spin
   do i=1,na
@@ -1803,7 +1801,7 @@ subroutine ac_operator(iorb,ispin,key,hjj,Nint,na,nb)
   key(k,ispin) = ibset(key(k,ispin),l)
   other_spin = iand(ispin,1)+1
 
-  hjj = hjj + mo_one_e_integrals(iorb,iorb)
+  hjj = hjj + mo_one_e_integrals_diag(iorb)
 
   ! Same spin
   do i=1,na
@@ -2292,3 +2290,607 @@ subroutine connected_to_hf(key_i,yes_no)
   yes_no = .True.
  endif
 end
+
+
+!==============================================================================!
+!                                                                              !
+!                                    Complex                                   !
+!                                                                              !
+!==============================================================================!
+
+
+subroutine i_H_j_s2_complex(key_i,key_j,Nint,hij,s2)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Returns $\langle i|H|j \rangle$ and $\langle i|S^2|j \rangle$
+  ! where $i$ and $j$ are determinants.
+  END_DOC
+  integer, intent(in)            :: Nint
+  integer(bit_kind), intent(in)  :: key_i(Nint,2), key_j(Nint,2)
+  complex*16, intent(out)  :: hij
+  double precision, intent(out)  :: s2
+
+  integer                        :: exc(0:2,2,2)
+  integer                        :: degree
+  complex*16               :: get_two_e_integral_complex
+  integer                        :: m,n,p,q
+  integer                        :: i,j,k
+  integer                        :: occ(Nint*bit_kind_size,2)
+  double precision               :: diag_h_mat_elem, phase
+  integer                        :: n_occ_ab(2)
+  PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals_complex
+
+  ASSERT (Nint > 0)
+  ASSERT (Nint == N_int)
+  ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num)
+  ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num)
+  ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num)
+  ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num)
+
+  hij = (0.d0,0.d0)
+  s2 = 0.d0
+  !DIR$ FORCEINLINE
+  call get_excitation_degree(key_i,key_j,degree,Nint)
+  integer :: spin
+  select case (degree)
+    case (2)
+      call get_double_excitation(key_i,key_j,exc,phase,Nint)
+      ! Single alpha, single beta
+      if (exc(0,1,1) == 1) then
+        if ( (exc(1,1,1) == exc(1,2,2)).and.(exc(1,1,2) == exc(1,2,1)) ) then
+          s2 =  -phase
+        endif
+        if(exc(1,1,1) == exc(1,2,2) )then
+          hij = phase * big_array_exchange_integrals_complex(exc(1,1,1),exc(1,1,2),exc(1,2,1))
+        else if (exc(1,2,1) ==exc(1,1,2))then
+          hij = phase * big_array_exchange_integrals_complex(exc(1,2,1),exc(1,1,1),exc(1,2,2))
+        else
+          hij = phase*get_two_e_integral_complex(                      &
+              exc(1,1,1),                                              &
+              exc(1,1,2),                                              &
+              exc(1,2,1),                                              &
+              exc(1,2,2) ,mo_integrals_map,mo_integrals_map_2)
+        endif
+      ! Double alpha
+      else if (exc(0,1,1) == 2) then
+        hij = phase*(get_two_e_integral_complex(                     &
+            exc(1,1,1),                                              &
+            exc(2,1,1),                                              &
+            exc(1,2,1),                                              &
+            exc(2,2,1) ,mo_integrals_map,mo_integrals_map_2) -       &
+            get_two_e_integral_complex(                              &
+            exc(1,1,1),                                              &
+            exc(2,1,1),                                              &
+            exc(2,2,1),                                              &
+            exc(1,2,1) ,mo_integrals_map,mo_integrals_map_2) )
+      ! Double beta
+      else if (exc(0,1,2) == 2) then
+        hij = phase*(get_two_e_integral_complex(                     &
+            exc(1,1,2),                                              &
+            exc(2,1,2),                                              &
+            exc(1,2,2),                                              &
+            exc(2,2,2) ,mo_integrals_map,mo_integrals_map_2) -       &
+            get_two_e_integral_complex(                              &
+            exc(1,1,2),                                              &
+            exc(2,1,2),                                              &
+            exc(2,2,2),                                              &
+            exc(1,2,2) ,mo_integrals_map,mo_integrals_map_2) )
+      endif
+    case (1)
+      call get_single_excitation(key_i,key_j,exc,phase,Nint)
+      !DIR$ FORCEINLINE
+      call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
+      ! Single alpha
+      if (exc(0,1,1) == 1) then
+        m = exc(1,1,1)
+        p = exc(1,2,1)
+        spin = 1
+      ! Single beta
+      else
+        m = exc(1,1,2)
+        p = exc(1,2,2)
+        spin = 2
+      endif
+      call get_single_excitation_from_fock_complex(key_i,key_j,m,p,spin,phase,hij)
+
+    case (0)
+      double precision, external :: diag_S_mat_elem
+      s2 = diag_S_mat_elem(key_i,Nint)
+      hij = dcmplx(diag_H_mat_elem(key_i,Nint),0.d0)
+  end select
+end
+
+
+
+subroutine i_H_j_complex(key_i,key_j,Nint,hij)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Returns $\langle i|H|j \rangle$ where $i$ and $j$ are determinants.
+  END_DOC
+  integer, intent(in)            :: Nint
+  integer(bit_kind), intent(in)  :: key_i(Nint,2), key_j(Nint,2)
+  complex*16, intent(out)  :: hij
+
+  integer                        :: exc(0:2,2,2)
+  integer                        :: degree
+  complex*16               :: get_two_e_integral_complex
+  integer                        :: m,n,p,q
+  integer                        :: i,j,k
+  integer :: ih1,ih2,ip1,ip2,kh1,kh2,kp1,kp2
+  integer                        :: occ(Nint*bit_kind_size,2)
+  double precision               :: diag_H_mat_elem, phase
+  integer                        :: n_occ_ab(2)
+  logical :: is_allowed
+  PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals_complex
+
+  ASSERT (Nint > 0)
+  ASSERT (Nint == N_int)
+  ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num)
+  ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num)
+  ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num)
+  ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num)
+
+
+  hij = (0.d0,0.d0)
+  !DIR$ FORCEINLINE
+  call get_excitation_degree(key_i,key_j,degree,Nint)
+  integer :: spin
+  select case (degree)
+    case (2)
+      call get_double_excitation(key_i,key_j,exc,phase,Nint)
+      if (exc(0,1,1) == 1) then
+        call double_allowed_mo_kpts(exc(1,1,1),exc(1,1,2),exc(1,2,1),exc(1,2,2),is_allowed)
+        if (.not.is_allowed) then
+          hij = (0.d0,0.d0)
+          return
+        endif
+        ! Single alpha, single beta
+        if(exc(1,1,1) == exc(1,2,2) )then
+          ih1 = mod(exc(1,1,1)-1,mo_num_per_kpt)+1
+          ih2 = mod(exc(1,1,2)-1,mo_num_per_kpt)+1
+          kh1 = (exc(1,1,1)-1)/mo_num_per_kpt+1
+          kh2 = (exc(1,1,2)-1)/mo_num_per_kpt+1
+          ip1 = mod(exc(1,2,1)-1,mo_num_per_kpt)+1
+          kp1 = (exc(1,2,1)-1)/mo_num_per_kpt+1
+          if(kp1.ne.kh2) then
+            print*,'problem with hij kpts: ',irp_here
+            print*,is_allowed
+            print*,exc(1,1,1),exc(1,1,2),exc(1,2,1),exc(1,2,2)
+            print*,ih1,kh1,ih2,kh2,ip1,kp1
+            stop -4
+          endif
+          hij = phase * big_array_exchange_integrals_kpts(ih1,kh1,ih2,ip1,kp1)
+          !hij = phase * big_array_exchange_integrals_complex(exc(1,1,1),exc(1,1,2),exc(1,2,1))
+        else if (exc(1,2,1) ==exc(1,1,2))then
+          ih1 = mod(exc(1,1,1)-1,mo_num_per_kpt)+1
+          kh1 = (exc(1,1,1)-1)/mo_num_per_kpt+1
+          ip1 = mod(exc(1,2,1)-1,mo_num_per_kpt)+1
+          kp1 = (exc(1,2,1)-1)/mo_num_per_kpt+1
+          ip2 = mod(exc(1,2,2)-1,mo_num_per_kpt)+1
+          kp2 = (exc(1,2,2)-1)/mo_num_per_kpt+1
+          if(kp2.ne.kh1) then
+            print*,'problem with hij kpts: ',irp_here
+            print*,is_allowed
+            print*,exc(1,1,1),exc(1,1,2),exc(1,2,1),exc(1,2,2)
+            print*,ip1,kp1,ip2,kp2,ih1,kh1
+            stop -5
+          endif
+          hij = phase * big_array_exchange_integrals_kpts(ip1,kp1,ih1,ip2,kp2)
+          !hij = phase * big_array_exchange_integrals_complex(exc(1,2,1),exc(1,1,1),exc(1,2,2))
+        else
+          hij = phase*get_two_e_integral_complex(                     &
+              exc(1,1,1),                                             &
+              exc(1,1,2),                                             &
+              exc(1,2,1),                                             &
+              exc(1,2,2) ,mo_integrals_map,mo_integrals_map_2)
+        endif
+      else if (exc(0,1,1) == 2) then
+        call double_allowed_mo_kpts(exc(1,1,1),exc(2,1,1),exc(1,2,1),exc(2,2,1),is_allowed)
+        if (.not.is_allowed) then
+          hij = (0.d0,0.d0)
+          return
+        endif
+        ! Double alpha
+        hij = phase*(get_two_e_integral_complex(                     &
+            exc(1,1,1),                                              &
+            exc(2,1,1),                                              &
+            exc(1,2,1),                                              &
+            exc(2,2,1) ,mo_integrals_map,mo_integrals_map_2) -       &
+            get_two_e_integral_complex(                              &
+            exc(1,1,1),                                              &
+            exc(2,1,1),                                              &
+            exc(2,2,1),                                              &
+            exc(1,2,1) ,mo_integrals_map,mo_integrals_map_2) )
+      else if (exc(0,1,2) == 2) then
+        call double_allowed_mo_kpts(exc(1,1,2),exc(2,1,2),exc(1,2,2),exc(2,2,2),is_allowed)
+        if (.not.is_allowed) then
+          hij = (0.d0,0.d0)
+          return
+        endif
+        ! Double beta
+        hij = phase*(get_two_e_integral_complex(                     &
+            exc(1,1,2),                                              &
+            exc(2,1,2),                                              &
+            exc(1,2,2),                                              &
+            exc(2,2,2) ,mo_integrals_map,mo_integrals_map_2) -       &
+            get_two_e_integral_complex(                              &
+            exc(1,1,2),                                              &
+            exc(2,1,2),                                              &
+            exc(2,2,2),                                              &
+            exc(1,2,2) ,mo_integrals_map,mo_integrals_map_2) )
+      endif
+    case (1)
+      call get_single_excitation(key_i,key_j,exc,phase,Nint)
+      !DIR$ FORCEINLINE
+      call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
+      if (exc(0,1,1) == 1) then
+        ! Single alpha
+        m = exc(1,1,1)
+        p = exc(1,2,1)
+        spin = 1
+      else
+        ! Single beta
+        m = exc(1,1,2)
+        p = exc(1,2,2)
+        spin = 2
+      endif
+      !if m,p not from same kpt, single not allowed
+      if (int((m-1)/mo_num_per_kpt + 1).ne.int((p-1)/mo_num_per_kpt + 1)) then
+        hij = (0.d0,0.d0)
+        return
+      endif
+      !call get_single_excitation_from_fock_complex(key_i,key_j,m,p,spin,phase,hij)
+      call get_single_excitation_from_fock_kpts(key_i,key_j,m,p,spin,phase,hij)
+
+    case (0)
+      hij = dcmplx(diag_H_mat_elem(key_i,Nint),0.d0)
+  end select
+end
+
+
+
+
+
+subroutine i_H_j_verbose_complex(key_i,key_j,Nint,hij,hmono,hdouble,phase)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Returns $\langle i|H|j \rangle$ where $i$ and $j$ are determinants.
+  END_DOC
+  integer, intent(in)            :: Nint
+  integer(bit_kind), intent(in)  :: key_i(Nint,2), key_j(Nint,2)
+  complex*16, intent(out)  :: hij,hmono,hdouble
+  double precision, intent(out)  :: phase
+
+  integer                        :: exc(0:2,2,2)
+  integer                        :: degree
+  complex*16               :: get_two_e_integral_complex
+  integer                        :: m,n,p,q
+  integer                        :: i,j,k
+  integer                        :: occ(Nint*bit_kind_size,2)
+  double precision               :: diag_H_mat_elem
+  integer                        :: n_occ_ab(2)
+  logical                        :: has_mipi(Nint*bit_kind_size)
+  complex*16               :: mipi(Nint*bit_kind_size), miip(Nint*bit_kind_size)
+  PROVIDE mo_two_e_integrals_in_map mo_integrals_map
+
+  ASSERT (Nint > 0)
+  ASSERT (Nint == N_int)
+  ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num)
+  ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num)
+  ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num)
+  ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num)
+
+  hij = (0.d0,0.d0)
+  hmono = (0.d0,0.d0)
+  hdouble = (0.d0,0.d0)
+  !DIR$ FORCEINLINE
+  call get_excitation_degree(key_i,key_j,degree,Nint)
+  select case (degree)
+    case (2)
+      call get_double_excitation(key_i,key_j,exc,phase,Nint)
+      if (exc(0,1,1) == 1) then
+        ! Single alpha, single beta
+        hij = phase*get_two_e_integral_complex(                      &
+            exc(1,1,1),                                              &
+            exc(1,1,2),                                              &
+            exc(1,2,1),                                              &
+            exc(1,2,2) ,mo_integrals_map,mo_integrals_map_2)
+      else if (exc(0,1,1) == 2) then
+        ! Double alpha
+        hij = phase*(get_two_e_integral_complex(                     &
+            exc(1,1,1),                                              &
+            exc(2,1,1),                                              &
+            exc(1,2,1),                                              &
+            exc(2,2,1) ,mo_integrals_map,mo_integrals_map_2) -       &
+            get_two_e_integral_complex(                              &
+            exc(1,1,1),                                              &
+            exc(2,1,1),                                              &
+            exc(2,2,1),                                              &
+            exc(1,2,1) ,mo_integrals_map,mo_integrals_map_2) )
+
+      else if (exc(0,1,2) == 2) then
+        ! Double beta
+        hij = phase*(get_two_e_integral_complex(                     &
+            exc(1,1,2),                                              &
+            exc(2,1,2),                                              &
+            exc(1,2,2),                                              &
+            exc(2,2,2) ,mo_integrals_map,mo_integrals_map_2) -       &
+            get_two_e_integral_complex(                              &
+            exc(1,1,2),                                              &
+            exc(2,1,2),                                              &
+            exc(2,2,2),                                              &
+            exc(1,2,2) ,mo_integrals_map,mo_integrals_map_2) )
+      endif
+    case (1)
+      call get_single_excitation(key_i,key_j,exc,phase,Nint)
+      !DIR$ FORCEINLINE
+      call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
+      has_mipi = .False.
+      if (exc(0,1,1) == 1) then
+        ! Single alpha
+        m = exc(1,1,1)
+        p = exc(1,2,1)
+        do k = 1, elec_alpha_num
+          i = occ(k,1)
+          if (.not.has_mipi(i)) then
+            mipi(i) = get_two_e_integral_complex(m,i,p,i,mo_integrals_map,mo_integrals_map_2)
+            miip(i) = get_two_e_integral_complex(m,i,i,p,mo_integrals_map,mo_integrals_map_2)
+            has_mipi(i) = .True.
+          endif
+        enddo
+        do k = 1, elec_beta_num
+          i = occ(k,2)
+          if (.not.has_mipi(i)) then
+            mipi(i) = get_two_e_integral_complex(m,i,p,i,mo_integrals_map,mo_integrals_map_2)
+            has_mipi(i) = .True.
+          endif
+        enddo
+
+        do k = 1, elec_alpha_num
+          hdouble = hdouble + mipi(occ(k,1)) - miip(occ(k,1))
+        enddo
+        do k = 1, elec_beta_num
+          hdouble = hdouble + mipi(occ(k,2))
+        enddo
+
+      else
+        ! Single beta
+        m = exc(1,1,2)
+        p = exc(1,2,2)
+        do k = 1, elec_beta_num
+          i = occ(k,2)
+          if (.not.has_mipi(i)) then
+            mipi(i) = get_two_e_integral_complex(m,i,p,i,mo_integrals_map,mo_integrals_map_2)
+            miip(i) = get_two_e_integral_complex(m,i,i,p,mo_integrals_map,mo_integrals_map_2)
+            has_mipi(i) = .True.
+          endif
+        enddo
+        do k = 1, elec_alpha_num
+          i = occ(k,1)
+          if (.not.has_mipi(i)) then
+            mipi(i) = get_two_e_integral_complex(m,i,p,i,mo_integrals_map,mo_integrals_map_2)
+            has_mipi(i) = .True.
+          endif
+        enddo
+
+        do k = 1, elec_alpha_num
+          hdouble = hdouble + mipi(occ(k,1))
+        enddo
+        do k = 1, elec_beta_num
+          hdouble = hdouble + mipi(occ(k,2)) - miip(occ(k,2))
+        enddo
+
+      endif
+      hmono = mo_one_e_integrals_complex(m,p)
+      hij = phase*(hdouble + hmono)
+
+    case (0)
+      phase = 1.d0
+      hij = dcmplx(diag_H_mat_elem(key_i,Nint),0.d0)
+  end select
+end
+
+
+subroutine i_H_psi_complex(key,keys,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+! Computes $\langle i|H|Psi \rangle  = \sum_J c_J \langle i | H | J \rangle$.
+!
+! Uses filter_connected_i_H_psi0 to get all the $|J \rangle$ to which $|i \rangle$
+! is connected.
+! The i_H_psi_minilist is much faster but requires to build the
+! minilists.
+  END_DOC
+  integer, intent(in)            :: Nint, Ndet,Ndet_max,Nstate
+  integer(bit_kind), intent(in)  :: keys(Nint,2,Ndet)
+  integer(bit_kind), intent(in)  :: key(Nint,2)
+  complex*16, intent(in)   :: coef(Ndet_max,Nstate)
+  complex*16, intent(out)  :: i_H_psi_array(Nstate)
+
+  integer                        :: i, ii,j
+  double precision               :: phase
+  integer                        :: exc(0:2,2,2)
+  complex*16               :: hij
+  integer, allocatable           :: idx(:)
+
+  ASSERT (Nint > 0)
+  ASSERT (N_int == Nint)
+  ASSERT (Nstate > 0)
+  ASSERT (Ndet > 0)
+  ASSERT (Ndet_max >= Ndet)
+  allocate(idx(0:Ndet))
+
+  i_H_psi_array = (0.d0,0.d0)
+
+  call filter_connected_i_h_psi0(keys,key,Nint,Ndet,idx)
+  if (Nstate == 1) then
+
+    do ii=1,idx(0)
+      i = idx(ii)
+      !DIR$ FORCEINLINE
+      call i_h_j_complex(key,keys(1,1,i),Nint,hij)
+      i_H_psi_array(1) = i_H_psi_array(1) + coef(i,1)*hij
+    enddo
+
+  else
+
+    do ii=1,idx(0)
+      i = idx(ii)
+      !DIR$ FORCEINLINE
+      call i_h_j_complex(key,keys(1,1,i),Nint,hij)
+      do j = 1, Nstate
+        i_H_psi_array(j) = i_H_psi_array(j) + coef(i,j)*hij
+      enddo
+    enddo
+
+  endif
+
+end
+
+
+subroutine i_H_psi_minilist_complex(key,keys,idx_key,N_minilist,coef,Nint,Ndet,Ndet_max,Nstate,i_H_psi_array)
+  use bitmasks
+  implicit none
+  integer, intent(in)            :: Nint, Ndet,Ndet_max,Nstate,idx_key(Ndet), N_minilist
+  integer(bit_kind), intent(in)  :: keys(Nint,2,Ndet)
+  integer(bit_kind), intent(in)  :: key(Nint,2)
+  complex*16, intent(in)   :: coef(Ndet_max,Nstate)
+  complex*16, intent(out)  :: i_H_psi_array(Nstate)
+
+  integer                        :: i, ii,j, i_in_key, i_in_coef
+  double precision               :: phase
+  integer                        :: exc(0:2,2,2)
+  complex*16               :: hij
+  integer, allocatable           :: idx(:)
+  BEGIN_DOC
+! Computes $\langle i|H|\Psi \rangle = \sum_J c_J \langle i|H|J\rangle$.
+!
+! Uses filter_connected_i_H_psi0 to get all the $|J \rangle$ to which $|i \rangle$
+! is connected. The $|J\rangle$ are searched in short pre-computed lists.
+  END_DOC
+
+  ASSERT (Nint > 0)
+  ASSERT (N_int == Nint)
+  ASSERT (Nstate > 0)
+  ASSERT (Ndet > 0)
+  ASSERT (Ndet_max >= Ndet)
+  allocate(idx(0:Ndet))
+  i_H_psi_array = 0.d0
+
+  call filter_connected_i_h_psi0(keys,key,Nint,N_minilist,idx)
+  if (Nstate == 1) then
+
+    do ii=1,idx(0)
+      i_in_key = idx(ii)
+      i_in_coef = idx_key(idx(ii))
+      !DIR$ FORCEINLINE
+      call i_h_j_complex(key,keys(1,1,i_in_key),Nint,hij)
+      ! TODO : Cache misses
+      i_H_psi_array(1) = i_H_psi_array(1) + coef(i_in_coef,1)*hij
+    enddo
+
+  else
+
+    do ii=1,idx(0)
+      i_in_key = idx(ii)
+      i_in_coef = idx_key(idx(ii))
+      !DIR$ FORCEINLINE
+      call i_h_j_complex(key,keys(1,1,i_in_key),Nint,hij)
+      do j = 1, Nstate
+        i_H_psi_array(j) = i_H_psi_array(j) + coef(i_in_coef,j)*hij
+      enddo
+    enddo
+
+  endif
+
+end
+
+
+
+subroutine i_H_j_single_spin_complex(key_i,key_j,Nint,spin,hij)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Returns $\langle i|H|j \rangle$ where $i$ and $j$ are determinants differing by
+  ! a single excitation.
+  END_DOC
+  integer, intent(in)            :: Nint, spin
+  integer(bit_kind), intent(in)  :: key_i(Nint,2), key_j(Nint,2)
+  complex*16, intent(out)  :: hij
+
+  integer                        :: exc(0:2,2)
+  double precision               :: phase
+
+  !PROVIDE big_array_exchange_integrals_complex mo_two_e_integrals_in_map
+  PROVIDE big_array_exchange_integrals_kpts mo_two_e_integrals_in_map
+
+  call get_single_excitation_spin(key_i(1,spin),key_j(1,spin),exc,phase,Nint)
+  !call get_single_excitation_from_fock_complex(key_i,key_j,exc(1,1),exc(1,2),spin,phase,hij)
+  call get_single_excitation_from_fock_kpts(key_i,key_j,exc(1,1),exc(1,2),spin,phase,hij)
+end
+
+subroutine i_H_j_double_spin_complex(key_i,key_j,Nint,hij)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Returns $\langle i|H|j \rangle$ where $i$ and $j$ are determinants differing by
+  ! a same-spin double excitation.
+  END_DOC
+  integer, intent(in)            :: Nint
+  integer(bit_kind), intent(in)  :: key_i(Nint), key_j(Nint)
+  complex*16, intent(out)  :: hij
+
+  integer                        :: exc(0:2,2)
+  double precision               :: phase
+  complex*16, external     :: get_two_e_integral_complex
+
+  PROVIDE big_array_exchange_integrals_complex mo_two_e_integrals_in_map
+  call get_double_excitation_spin(key_i,key_j,exc,phase,Nint)
+  hij = phase*(get_two_e_integral_complex(                             &
+      exc(1,1),                                                    &
+      exc(2,1),                                                    &
+      exc(1,2),                                                    &
+      exc(2,2), mo_integrals_map,mo_integrals_map_2) -                                &
+      get_two_e_integral_complex(                                      &
+      exc(1,1),                                                    &
+      exc(2,1),                                                    &
+      exc(2,2),                                                    &
+      exc(1,2), mo_integrals_map,mo_integrals_map_2) )
+end
+
+subroutine i_H_j_double_alpha_beta_complex(key_i,key_j,Nint,hij)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Returns $\langle i|H|j \rangle$ where $i$ and $j$ are determinants differing by
+  ! an opposite-spin double excitation.
+  END_DOC
+  integer, intent(in)            :: Nint
+  integer(bit_kind), intent(in)  :: key_i(Nint,2), key_j(Nint,2)
+  complex*16, intent(out)  :: hij
+
+  integer                        :: exc(0:2,2,2)
+  double precision               :: phase, phase2
+  complex*16, external     :: get_two_e_integral_complex
+
+  PROVIDE big_array_exchange_integrals_complex mo_two_e_integrals_in_map
+
+  call get_single_excitation_spin(key_i(1,1),key_j(1,1),exc(0,1,1),phase,Nint)
+  call get_single_excitation_spin(key_i(1,2),key_j(1,2),exc(0,1,2),phase2,Nint)
+  phase = phase*phase2
+  if (exc(1,1,1) == exc(1,2,2)) then
+    hij = phase * big_array_exchange_integrals_complex(exc(1,1,1),exc(1,1,2),exc(1,2,1))
+  else if (exc(1,2,1) == exc(1,1,2)) then
+    hij = phase * big_array_exchange_integrals_complex(exc(1,2,1),exc(1,1,1),exc(1,2,2))
+  else
+    hij = phase*get_two_e_integral_complex(                              &
+        exc(1,1,1),                                                  &
+        exc(1,1,2),                                                  &
+        exc(1,2,1),                                                  &
+        exc(1,2,2) ,mo_integrals_map,mo_integrals_map_2)
+  endif
+end

src/determinants/slater_rules_wee_mono.irp.f

@@ -225,7 +225,7 @@ double precision function diag_H_mat_elem_one_e(det_in,Nint)
   call bitstring_to_list_ab(det_in, occ_particle, tmp, Nint)
   do ispin = 1,2
    do i = 1, tmp(ispin)
-    diag_H_mat_elem_one_e +=  mo_one_e_integrals(occ_particle(i,ispin),occ_particle(i,ispin))
+    diag_H_mat_elem_one_e +=  mo_one_e_integrals_diag(occ_particle(i,ispin))
    enddo
   enddo
 
@@ -361,3 +361,180 @@ subroutine i_H_j_two_e(key_i,key_j,Nint,hij)
   end select
 end
 
+!==============================================================================!
+!                                                                              !
+!                                    Complex                                   !
+!                                                                              !
+!==============================================================================!
+
+subroutine i_Wee_j_single_complex(key_i,key_j,Nint,spin,hij)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Returns $\langle i|H|j \rangle$  where $i$ and $j$ are determinants differing by a
+  ! single excitation.
+  END_DOC
+  integer, intent(in)            :: Nint, spin
+  integer(bit_kind), intent(in)  :: key_i(Nint,2), key_j(Nint,2)
+  complex*16, intent(out)  :: hij
+
+  integer                        :: exc(0:2,2)
+  double precision               :: phase
+
+  PROVIDE big_array_exchange_integrals_complex mo_two_e_integrals_in_map
+
+  call get_single_excitation_spin(key_i(1,spin),key_j(1,spin),exc,phase,Nint)
+  call single_excitation_wee_complex(key_i,key_j,exc(1,1),exc(1,2),spin,phase,hij)
+end
+
+
+subroutine i_H_j_mono_spin_one_e_complex(key_i,key_j,Nint,spin,hij)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Returns $\langle i|H|j \rangle$  where $i$ and $j$ are determinants differing by
+  ! a single excitation.
+  END_DOC
+  integer, intent(in)            :: Nint, spin
+  integer(bit_kind), intent(in)  :: key_i(Nint,2), key_j(Nint,2)
+  complex*16, intent(out)  :: hij
+
+  integer                        :: exc(0:2,2)
+  double precision               :: phase
+
+  call get_single_excitation_spin(key_i(1,spin),key_j(1,spin),exc,phase,Nint)
+  integer :: m,p
+  m = exc(1,1)
+  p = exc(1,2)
+  hij = phase * mo_one_e_integrals_complex(m,p)
+end
+
+subroutine i_H_j_one_e_complex(key_i,key_j,Nint,hij)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Returns $\langle i|H|j \rangle$  where $i$ and $j$ are determinants.
+  END_DOC
+  integer, intent(in)            :: Nint
+  integer(bit_kind), intent(in)  :: key_i(Nint,2), key_j(Nint,2)
+  complex*16, intent(out)  :: hij
+
+  integer :: degree,m,p
+  double precision :: diag_h_mat_elem_one_e,phase
+  integer                        :: exc(0:2,2,2)
+  call get_excitation_degree(key_i,key_j,degree,Nint)
+  hij = (0.d0,0.d0)
+  if(degree>1)then
+   return
+  endif
+  if(degree==0)then
+   hij = dcmplx(diag_h_mat_elem_one_e(key_i,N_int),0.d0)
+  else
+   call get_single_excitation(key_i,key_j,exc,phase,Nint)
+   if (exc(0,1,1) == 1) then
+     ! Mono alpha
+     m = exc(1,1,1)
+     p = exc(1,2,1)
+   else
+     ! Mono beta
+     m = exc(1,1,2)
+     p = exc(1,2,2)
+   endif
+   hij = phase * mo_one_e_integrals_complex(m,p)
+  endif
+
+end
+
+subroutine i_H_j_two_e_complex(key_i,key_j,Nint,hij)
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Returns $\langle i|H|j \rangle$  where $i$ and $j$ are determinants.
+  END_DOC
+  integer, intent(in)            :: Nint
+  integer(bit_kind), intent(in)  :: key_i(Nint,2), key_j(Nint,2)
+  complex*16, intent(out)  :: hij
+
+  integer                        :: exc(0:2,2,2)
+  integer                        :: degree
+  complex*16               :: get_two_e_integral_complex
+  integer                        :: m,n,p,q
+  integer                        :: i,j,k
+  integer                        :: occ(Nint*bit_kind_size,2)
+  double precision               :: diag_H_mat_elem, phase,phase_2
+  integer                        :: n_occ_ab(2)
+  PROVIDE mo_two_e_integrals_in_map mo_integrals_map big_array_exchange_integrals_complex ref_bitmask_two_e_energy
+
+  ASSERT (Nint > 0)
+  ASSERT (Nint == N_int)
+  ASSERT (sum(popcnt(key_i(:,1))) == elec_alpha_num)
+  ASSERT (sum(popcnt(key_i(:,2))) == elec_beta_num)
+  ASSERT (sum(popcnt(key_j(:,1))) == elec_alpha_num)
+  ASSERT (sum(popcnt(key_j(:,2))) == elec_beta_num)
+
+  hij = (0.d0,0.d0)
+  !DIR$ FORCEINLINE
+  call get_excitation_degree(key_i,key_j,degree,Nint)
+  integer :: spin
+  select case (degree)
+    case (2)
+      call get_double_excitation(key_i,key_j,exc,phase,Nint)
+      if (exc(0,1,1) == 1) then
+        ! Mono alpha, mono beta
+        if(exc(1,1,1) == exc(1,2,2) )then
+         hij = phase * big_array_exchange_integrals_complex(exc(1,1,1),exc(1,1,2),exc(1,2,1))
+        else if (exc(1,2,1) ==exc(1,1,2))then
+         hij = phase * big_array_exchange_integrals_complex(exc(1,2,1),exc(1,1,1),exc(1,2,2))
+        else
+         hij = phase*get_two_e_integral_complex(                   &
+             exc(1,1,1),                                              &
+             exc(1,1,2),                                              &
+             exc(1,2,1),                                              &
+             exc(1,2,2) ,mo_integrals_map,mo_integrals_map_2)
+        endif
+      else if (exc(0,1,1) == 2) then
+        ! Double alpha
+        hij = phase*(get_two_e_integral_complex(                     &
+            exc(1,1,1),                                              &
+            exc(2,1,1),                                              &
+            exc(1,2,1),                                              &
+            exc(2,2,1) ,mo_integrals_map,mo_integrals_map_2) -       &
+            get_two_e_integral_complex(                              &
+            exc(1,1,1),                                              &
+            exc(2,1,1),                                              &
+            exc(2,2,1),                                              &
+            exc(1,2,1) ,mo_integrals_map,mo_integrals_map_2) )
+      else if (exc(0,1,2) == 2) then
+        ! Double beta
+        hij = phase*(get_two_e_integral_complex(                     &
+            exc(1,1,2),                                              &
+            exc(2,1,2),                                              &
+            exc(1,2,2),                                              &
+            exc(2,2,2) ,mo_integrals_map,mo_integrals_map_2) -       &
+            get_two_e_integral_complex(                              &
+            exc(1,1,2),                                              &
+            exc(2,1,2),                                              &
+            exc(2,2,2),                                              &
+            exc(1,2,2) ,mo_integrals_map,mo_integrals_map_2) )
+      endif
+    case (1)
+      call get_single_excitation(key_i,key_j,exc,phase,Nint)
+      !DIR$ FORCEINLINE
+      call bitstring_to_list_ab(key_i, occ, n_occ_ab, Nint)
+      if (exc(0,1,1) == 1) then
+        ! Mono alpha
+        m = exc(1,1,1)
+        p = exc(1,2,1)
+        spin = 1
+      else
+        ! Mono beta
+        m = exc(1,1,2)
+        p = exc(1,2,2)
+        spin = 2
+      endif
+      call single_excitation_wee_complex(key_i,key_j,m,p,spin,phase,hij)
+    case (0)
+      double precision :: diag_wee_mat_elem
+      hij = dcmplx(diag_wee_mat_elem(key_i,Nint),0.d0)
+  end select
+end

src/determinants/spindeterminants.ezfio_config

@@ -10,6 +10,7 @@ spindeterminants
   psi_coef_matrix_rows    integer (spindeterminants_n_det)
   psi_coef_matrix_columns integer (spindeterminants_n_det)
   psi_coef_matrix_values  double precision (spindeterminants_n_det,spindeterminants_n_states)
+  psi_coef_matrix_values_complex  double precision (2,spindeterminants_n_det,spindeterminants_n_states)
   n_svd_coefs     integer
   psi_svd_alpha   double precision (spindeterminants_n_det_alpha,spindeterminants_n_svd_coefs,spindeterminants_n_states)
   psi_svd_beta    double precision (spindeterminants_n_det_beta,spindeterminants_n_svd_coefs,spindeterminants_n_states)

src/determinants/spindeterminants.irp.f

@@ -307,8 +307,12 @@ integer function get_index_in_psi_det_beta_unique(key,Nint)
 
 end
 
-
 subroutine write_spindeterminants
+  !todo: modify for complex (not called anywhere?)
+  if (is_complex) then
+    print*,irp_here,' not implemented for complex'
+    stop -1
+  endif
   use bitmasks
   implicit none
   integer(8), allocatable        :: tmpdet(:,:)
@@ -349,8 +353,12 @@ subroutine write_spindeterminants
   enddo
   call ezfio_set_spindeterminants_psi_det_beta(psi_det_beta_unique)
   deallocate(tmpdet)
-
+  
+  if (is_complex) then
+    call ezfio_set_spindeterminants_psi_coef_matrix_values_complex(psi_bilinear_matrix_values_complex)
+  else
   call ezfio_set_spindeterminants_psi_coef_matrix_values(psi_bilinear_matrix_values)
+  endif
   call ezfio_set_spindeterminants_psi_coef_matrix_rows(psi_bilinear_matrix_rows)
   call ezfio_set_spindeterminants_psi_coef_matrix_columns(psi_bilinear_matrix_columns)
 
@@ -370,6 +378,18 @@ end
 
   det_alpha_norm = 0.d0
   det_beta_norm  = 0.d0
+  if (is_complex) then
+    do k=1,N_det
+      i = psi_bilinear_matrix_rows(k)
+      j = psi_bilinear_matrix_columns(k)
+      f = 0.d0
+      do l=1,N_states
+        f += cdabs(psi_bilinear_matrix_values_complex(k,l)*psi_bilinear_matrix_values_complex(k,l)) * state_average_weight(l)
+      enddo
+      det_alpha_norm(i) += f
+      det_beta_norm(j)  += f
+    enddo
+  else
   do k=1,N_det
     i = psi_bilinear_matrix_rows(k)
     j = psi_bilinear_matrix_columns(k)
@@ -380,6 +400,7 @@ end
     det_alpha_norm(i) += f
     det_beta_norm(j)  += f
   enddo
+  endif
   det_alpha_norm = det_alpha_norm
   det_beta_norm = det_beta_norm
 
@@ -392,8 +413,37 @@ END_PROVIDER
 !                                                                              !
 !==============================================================================!
 
- BEGIN_PROVIDER  [ double precision, psi_bilinear_matrix_values, (N_det,N_states) ]
-&BEGIN_PROVIDER [ integer, psi_bilinear_matrix_rows   , (N_det) ]
+BEGIN_PROVIDER  [ double precision, psi_bilinear_matrix_values, (N_det,N_states) ]
+  use bitmasks
+  PROVIDE psi_bilinear_matrix_rows
+  integer :: k,l
+  do k=1,N_det
+    do l=1,N_states
+      psi_bilinear_matrix_values(k,l) = psi_coef(k,l)
+    enddo
+  enddo
+  do l=1,N_states
+    call dset_order(psi_bilinear_matrix_values(1,l),psi_bilinear_matrix_order,N_det)
+  enddo
+END_PROVIDER
+
+BEGIN_PROVIDER  [ complex*16, psi_bilinear_matrix_values_complex, (N_det,N_states) ]
+  use bitmasks
+  PROVIDE psi_bilinear_matrix_rows
+  integer :: k,l
+  do k=1,N_det
+    do l=1,N_states
+      psi_bilinear_matrix_values_complex(k,l) = psi_coef_complex(k,l)
+    enddo
+  enddo
+  do l=1,N_states
+    call cdset_order(psi_bilinear_matrix_values_complex(1,l),psi_bilinear_matrix_order,N_det)
+  enddo
+END_PROVIDER
+
+
+
+ BEGIN_PROVIDER [ integer, psi_bilinear_matrix_rows   , (N_det) ]
 &BEGIN_PROVIDER [ integer, psi_bilinear_matrix_columns, (N_det) ]
 &BEGIN_PROVIDER [ integer, psi_bilinear_matrix_order  , (N_det) ]
   use bitmasks
@@ -408,10 +458,13 @@ END_PROVIDER
   END_DOC
   integer                        :: i,j,k, l
   integer(bit_kind)              :: tmp_det(N_int,2)
-  integer, external              :: get_index_in_psi_det_sorted_bit
+!  integer, external              :: get_index_in_psi_det_sorted_bit
 
-
-  PROVIDE psi_coef_sorted_bit
+  if (is_complex) then
+    PROVIDE psi_coef_sorted_bit_complex
+  else
+    PROVIDE psi_coef_sorted_bit
+  endif
 
   integer*8, allocatable         :: to_sort(:)
   integer, external              :: get_index_in_psi_det_alpha_unique
@@ -427,9 +480,6 @@ END_PROVIDER
     ASSERT (j>0)
     ASSERT (j<=N_det_beta_unique)
 
-    do l=1,N_states
-      psi_bilinear_matrix_values(k,l) = psi_coef(k,l)
-    enddo
     psi_bilinear_matrix_rows(k) = i
     psi_bilinear_matrix_columns(k) = j
     to_sort(k) = int(N_det_alpha_unique,8) * int(j-1,8) + int(i,8)
@@ -445,11 +495,6 @@ END_PROVIDER
   !$OMP SINGLE
   call iset_order(psi_bilinear_matrix_columns,psi_bilinear_matrix_order,N_det)
   !$OMP END SINGLE
-  !$OMP DO
-  do l=1,N_states
-    call dset_order(psi_bilinear_matrix_values(1,l),psi_bilinear_matrix_order,N_det)
-  enddo
-  !$OMP END DO
   !$OMP END PARALLEL
   deallocate(to_sort)
   ASSERT (minval(psi_bilinear_matrix_rows) == 1)
@@ -514,8 +559,71 @@ BEGIN_PROVIDER [ integer, psi_bilinear_matrix_columns_loc, (N_det_beta_unique+1)
 
 END_PROVIDER
 
- BEGIN_PROVIDER  [ double precision, psi_bilinear_matrix_transp_values, (N_det,N_states) ]
-&BEGIN_PROVIDER [ integer, psi_bilinear_matrix_transp_rows   , (N_det) ]
+BEGIN_PROVIDER  [ double precision, psi_bilinear_matrix_transp_values, (N_det,N_states) ]
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Transpose of :c:data:`psi_bilinear_matrix`
+  !
+  ! $D_\beta^\dagger.C^\dagger.D_\alpha$
+  !
+  ! Rows are $\alpha$ determinants and columns are $\beta$, but the matrix is stored in row major
+  ! format.
+  END_DOC
+  integer                        :: k,l
+
+  PROVIDE psi_bilinear_matrix_transp_rows
+
+  !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(k,l)
+  do l=1,N_states
+    !$OMP DO
+    do k=1,N_det
+      psi_bilinear_matrix_transp_values (k,l) = psi_bilinear_matrix_values (k,l)
+    enddo
+    !$OMP ENDDO NOWAIT
+  enddo
+  !$OMP END PARALLEL
+  !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(l)
+  do l=1,N_states
+    call dset_order(psi_bilinear_matrix_transp_values(1,l),psi_bilinear_matrix_transp_order,N_det)
+  enddo
+  !$OMP END PARALLEL DO
+
+END_PROVIDER
+
+BEGIN_PROVIDER  [ complex*16, psi_bilinear_matrix_transp_values_complex, (N_det,N_states) ]
+  use bitmasks
+  implicit none
+  BEGIN_DOC
+  ! Transpose of :c:data:`psi_bilinear_matrix`
+  !
+  ! $D_\beta^\dagger.C^\dagger.D_\alpha$
+  !
+  ! Rows are $\alpha$ determinants and columns are $\beta$, but the matrix is stored in row major
+  ! format.
+  END_DOC
+  integer                        :: k,l
+
+  PROVIDE psi_bilinear_matrix_transp_rows
+
+  !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(k,l)
+  do l=1,N_states
+    !$OMP DO
+    do k=1,N_det
+      psi_bilinear_matrix_transp_values_complex (k,l) = psi_bilinear_matrix_values_complex (k,l)
+    enddo
+    !$OMP ENDDO NOWAIT
+  enddo
+  !$OMP END PARALLEL
+  !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(l)
+  do l=1,N_states
+    call cdset_order(psi_bilinear_matrix_transp_values_complex(1,l),psi_bilinear_matrix_transp_order,N_det)
+  enddo
+  !$OMP END PARALLEL DO
+
+END_PROVIDER
+
+ BEGIN_PROVIDER [ integer, psi_bilinear_matrix_transp_rows   , (N_det) ]
 &BEGIN_PROVIDER [ integer, psi_bilinear_matrix_transp_columns, (N_det) ]
 &BEGIN_PROVIDER [ integer, psi_bilinear_matrix_transp_order  , (N_det) ]
   use bitmasks
@@ -530,18 +638,15 @@ END_PROVIDER
   END_DOC
   integer                        :: i,j,k,l
 
-  PROVIDE psi_coef_sorted_bit
+  if (is_complex) then
+    PROVIDE psi_coef_sorted_bit_complex
+  else
+    PROVIDE psi_coef_sorted_bit
+  endif
 
   integer*8, allocatable         :: to_sort(:)
   allocate(to_sort(N_det))
   !$OMP PARALLEL DEFAULT(SHARED) PRIVATE(i,j,k,l)
-  do l=1,N_states
-    !$OMP DO
-    do k=1,N_det
-      psi_bilinear_matrix_transp_values (k,l) = psi_bilinear_matrix_values (k,l)
-    enddo
-    !$OMP ENDDO NOWAIT
-  enddo
   !$OMP DO
   do k=1,N_det
     psi_bilinear_matrix_transp_columns(k) = psi_bilinear_matrix_columns(k)
@@ -563,11 +668,6 @@ END_PROVIDER
   call i8radix_sort(to_sort, psi_bilinear_matrix_transp_order, N_det,-1)
   call iset_order(psi_bilinear_matrix_transp_rows,psi_bilinear_matrix_transp_order,N_det)
   call iset_order(psi_bilinear_matrix_transp_columns,psi_bilinear_matrix_transp_order,N_det)
-  !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(l)
-  do l=1,N_states
-    call dset_order(psi_bilinear_matrix_transp_values(1,l),psi_bilinear_matrix_transp_order,N_det)
-  enddo
-  !$OMP END PARALLEL DO
   deallocate(to_sort)
   ASSERT (minval(psi_bilinear_matrix_transp_columns) == 1)
   ASSERT (minval(psi_bilinear_matrix_transp_rows) == 1)
@@ -641,7 +741,30 @@ BEGIN_PROVIDER [ double precision, psi_bilinear_matrix, (N_det_alpha_unique,N_de
   enddo
 END_PROVIDER
 
+BEGIN_PROVIDER [ complex*16, psi_bilinear_matrix_complex, (N_det_alpha_unique,N_det_beta_unique,N_states) ]
+  implicit none
+  BEGIN_DOC
+  ! Coefficient matrix if the wave function is expressed in a bilinear form :
+  !
+  ! $D_\alpha^\dagger.C.D_\beta$
+  END_DOC
+  integer                        :: i,j,k,istate
+  psi_bilinear_matrix_complex = (0.d0,0.d0)
+  do k=1,N_det
+    i = psi_bilinear_matrix_rows(k)
+    j = psi_bilinear_matrix_columns(k)
+    do istate=1,N_states
+      psi_bilinear_matrix_complex(i,j,istate) = psi_bilinear_matrix_values_complex(k,istate)
+    enddo
+  enddo
+END_PROVIDER
+
 subroutine create_wf_of_psi_bilinear_matrix(truncate)
+  !todo: modify for complex (not called anywhere?)
+  if (is_complex) then
+    print*,irp_here,' not implemented for complex'
+    stop -1
+  endif
   use bitmasks
   implicit none
   BEGIN_DOC
@@ -713,6 +836,11 @@ subroutine create_wf_of_psi_bilinear_matrix(truncate)
 end
 
 subroutine generate_all_alpha_beta_det_products
+  !todo: modify for complex (only used by create_wf_of_psi_bilinear_matrix?)
+  if (is_complex) then
+    print*,irp_here,' not implemented for complex'
+    stop -1
+  endif
   implicit none
   BEGIN_DOC
   ! Creates a wave function from all possible $\alpha \times \beta$ determinants
@@ -856,6 +984,11 @@ end
 
 
 subroutine copy_psi_bilinear_to_psi(psi, isize)
+  !todo: modify for complex (not called anywhere?)
+  if (is_complex) then
+    print*,irp_here,' not implemented for complex'
+    stop -1
+  endif
   implicit none
   BEGIN_DOC
   ! Overwrites :c:data:`psi_det` and :c:data:`psi_coef` with the wave function
@@ -1292,6 +1425,11 @@ END_TEMPLATE
 
 
 subroutine wf_of_psi_bilinear_matrix(truncate)
+  !todo: modify for complex (not called anywhere?)
+  if (is_complex) then
+    print*,irp_here,' not implemented for complex'
+    stop -1
+  endif
   use bitmasks
   implicit none
   BEGIN_DOC

src/determinants/utils.irp.f

@@ -20,6 +20,28 @@ BEGIN_PROVIDER [ double precision, H_matrix_all_dets,(N_det,N_det) ]
  !$OMP END PARALLEL DO
 END_PROVIDER
 
+BEGIN_PROVIDER [ complex*16, h_matrix_all_dets_complex,(N_det,N_det) ]
+  use bitmasks
+ implicit none
+ BEGIN_DOC
+ ! |H| matrix on the basis of the Slater determinants defined by psi_det
+ END_DOC
+ integer :: i,j,k
+ complex*16 :: hij
+ integer :: degree(N_det),idx(0:N_det)
+ call  i_h_j_complex(psi_det(1,1,1),psi_det(1,1,1),N_int,hij)
+ !$OMP PARALLEL DO SCHEDULE(GUIDED) DEFAULT(NONE) PRIVATE(i,j,hij,degree,idx,k) &
+ !$OMP SHARED (N_det, psi_det, N_int,h_matrix_all_dets_complex)
+ do i =1,N_det
+   do j = i, N_det
+    call  i_h_j_complex(psi_det(1,1,i),psi_det(1,1,j),N_int,hij)
+    H_matrix_all_dets_complex(i,j) = hij
+    H_matrix_all_dets_complex(j,i) = dconjg(hij)
+  enddo
+ enddo
+ !$OMP END PARALLEL DO
+END_PROVIDER
+
 
 BEGIN_PROVIDER [ double precision, S2_matrix_all_dets,(N_det,N_det) ]
   use bitmasks

src/determinants/zmq.irp.f

@@ -13,6 +13,7 @@ integer function zmq_put_psi(zmq_to_qp_run_socket,worker_id)
   integer, external              :: zmq_put_psi_det_size
   integer*8, external            :: zmq_put_psi_det
   integer*8, external            :: zmq_put_psi_coef
+  integer*8, external            :: zmq_put_psi_coef_complex
 
   zmq_put_psi = 0
   if (zmq_put_N_states(zmq_to_qp_run_socket, worker_id) == -1) then
@@ -31,11 +32,17 @@ integer function zmq_put_psi(zmq_to_qp_run_socket,worker_id)
     zmq_put_psi = -1
     return
   endif
+  if (is_complex) then
+    if (zmq_put_psi_coef_complex(zmq_to_qp_run_socket, worker_id) == -1) then
+      zmq_put_psi = -1
+      return
+    endif
+  else
   if (zmq_put_psi_coef(zmq_to_qp_run_socket, worker_id) == -1) then
     zmq_put_psi = -1
     return
   endif
-
+  endif
 end
 
 
@@ -54,6 +61,7 @@ integer function zmq_get_psi_notouch(zmq_to_qp_run_socket, worker_id)
   integer, external              :: zmq_get_psi_det_size
   integer*8, external            :: zmq_get_psi_det
   integer*8, external            :: zmq_get_psi_coef
+  integer*8, external            :: zmq_get_psi_coef_complex
 
   zmq_get_psi_notouch = 0
 
@@ -75,19 +83,34 @@ integer function zmq_get_psi_notouch(zmq_to_qp_run_socket, worker_id)
     allocate(psi_det(N_int,2,psi_det_size))
   endif
 
+  if (is_complex) then
+    if (size(psi_coef_complex,kind=8) /= psi_det_size*N_states) then
+      deallocate(psi_coef_complex)
+      allocate(psi_coef_complex(psi_det_size,N_states))
+    endif
+  else
   if (size(psi_coef,kind=8) /= psi_det_size*N_states) then
     deallocate(psi_coef)
     allocate(psi_coef(psi_det_size,N_states))
   endif
+  endif
 
   if (zmq_get_psi_det(zmq_to_qp_run_socket, worker_id) == -1_8) then
     zmq_get_psi_notouch = -1
     return
   endif
+
+  if (is_complex) then
+    if (zmq_get_psi_coef_complex(zmq_to_qp_run_socket, worker_id) == -1_8) then
+      zmq_get_psi_notouch = -1
+      return
+    endif
+  else
   if (zmq_get_psi_coef(zmq_to_qp_run_socket, worker_id) == -1_8) then
     zmq_get_psi_notouch = -1
     return
   endif
+  endif
 
 end
 
@@ -102,8 +125,11 @@ integer function zmq_get_psi(zmq_to_qp_run_socket, worker_id)
   integer, intent(in)            :: worker_id
   integer, external :: zmq_get_psi_notouch
   zmq_get_psi = zmq_get_psi_notouch(zmq_to_qp_run_socket, worker_id)
+  if (is_complex) then
+    SOFT_TOUCH psi_det psi_coef_complex psi_det_size N_det N_states
+  else
   SOFT_TOUCH psi_det psi_coef psi_det_size N_det N_states
-
+  endif
 end
 
 
@@ -146,12 +172,20 @@ integer function zmq_put_psi_bilinear(zmq_to_qp_run_socket,worker_id)
     zmq_put_psi_bilinear = -1
     return
   endif
-
+  
+  if (is_complex) then
+    integer*8, external            :: zmq_put_psi_bilinear_matrix_values_complex
+    if (zmq_put_psi_bilinear_matrix_values_complex(zmq_to_qp_run_socket, worker_id) == -1) then
+      zmq_put_psi_bilinear = -1
+      return
+    endif
+  else
   integer*8, external            :: zmq_put_psi_bilinear_matrix_values
   if (zmq_put_psi_bilinear_matrix_values(zmq_to_qp_run_socket, worker_id) == -1) then
     zmq_put_psi_bilinear = -1
     return
   endif
+  endif
 
   integer, external            :: zmq_put_N_det_alpha_unique
   if (zmq_put_N_det_alpha_unique(zmq_to_qp_run_socket,worker_id) == -1) then
@@ -197,10 +231,17 @@ integer function zmq_get_psi_bilinear(zmq_to_qp_run_socket, worker_id)
 
   zmq_get_psi_bilinear= 0
 
+  if (is_complex) then
+    if (size(psi_bilinear_matrix_values_complex,kind=8) /= N_det*N_states) then
+      deallocate(psi_bilinear_matrix_values_complex)
+      allocate(psi_bilinear_matrix_values_complex(N_det,N_states))
+    endif
+  else
   if (size(psi_bilinear_matrix_values,kind=8) /= N_det*N_states) then
     deallocate(psi_bilinear_matrix_values)
     allocate(psi_bilinear_matrix_values(N_det,N_states))
   endif
+  endif
 
   if (size(psi_bilinear_matrix_rows,kind=8) /= N_det) then
     deallocate(psi_bilinear_matrix_rows)
@@ -216,12 +257,20 @@ integer function zmq_get_psi_bilinear(zmq_to_qp_run_socket, worker_id)
     deallocate(psi_bilinear_matrix_order)
     allocate(psi_bilinear_matrix_order(N_det))
   endif
-
+  
+  if (is_complex) then
+    integer*8, external            :: zmq_get_psi_bilinear_matrix_values_complex
+    if (zmq_get_psi_bilinear_matrix_values_complex(zmq_to_qp_run_socket, worker_id) == -1_8) then
+      zmq_get_psi_bilinear = -1
+      return
+    endif
+  else
   integer*8, external            :: zmq_get_psi_bilinear_matrix_values
   if (zmq_get_psi_bilinear_matrix_values(zmq_to_qp_run_socket, worker_id) == -1_8) then
     zmq_get_psi_bilinear = -1
     return
   endif
+  endif
 
   integer*8, external            :: zmq_get_psi_bilinear_matrix_rows
   if (zmq_get_psi_bilinear_matrix_rows(zmq_to_qp_run_socket, worker_id) == -1_8) then
@@ -266,7 +315,11 @@ integer function zmq_get_psi_bilinear(zmq_to_qp_run_socket, worker_id)
     return
   endif
 
+  if (is_complex) then
+    SOFT_TOUCH psi_bilinear_matrix_values_complex psi_bilinear_matrix_rows psi_bilinear_matrix_columns psi_bilinear_matrix_order psi_det psi_coef_complex psi_det_size N_det N_states psi_det_beta_unique psi_det_alpha_unique N_det_beta_unique N_det_alpha_unique
+  else
   SOFT_TOUCH psi_bilinear_matrix_values psi_bilinear_matrix_rows psi_bilinear_matrix_columns psi_bilinear_matrix_order psi_det psi_coef psi_det_size N_det N_states psi_det_beta_unique psi_det_alpha_unique N_det_beta_unique N_det_alpha_unique
+  endif
 
 end
 
@@ -563,6 +616,69 @@ psi_bilinear_matrix_values ;;
 
 END_TEMPLATE
 
+BEGIN_TEMPLATE
+
+integer*8 function zmq_put_$X(zmq_to_qp_run_socket,worker_id)
+  use f77_zmq
+  implicit none
+  BEGIN_DOC
+! Put $X on the qp_run scheduler
+  END_DOC
+  integer(ZMQ_PTR), intent(in)   :: zmq_to_qp_run_socket
+  integer, intent(in)            :: worker_id
+  integer*8                      :: rc8
+  character*(256)                :: msg
+
+  zmq_put_$X = 0
+
+  integer*8 :: zmq_put_cdmatrix
+  integer   :: ni, nj
+
+  if (size($X,kind=8) <= 8388608_8) then
+    ni = size($X,kind=4)
+    nj = 1
+  else
+    ni = 8388608
+    nj = int(size($X,kind=8)/8388608_8,4) + 1
+  endif
+  rc8 = zmq_put_cdmatrix(zmq_to_qp_run_socket, 1, '$X', $X, ni, nj, size($X,kind=8) )
+  zmq_put_$X = rc8
+end
+
+integer*8 function zmq_get_$X(zmq_to_qp_run_socket,worker_id)
+  use f77_zmq
+  implicit none
+  BEGIN_DOC
+! get $X on the qp_run scheduler
+  END_DOC
+  integer(ZMQ_PTR), intent(in)   :: zmq_to_qp_run_socket
+  integer, intent(in)            :: worker_id
+  integer*8                      :: rc8
+  character*(256)                :: msg
+
+  zmq_get_$X = 0_8
+
+  integer*8 :: zmq_get_cdmatrix
+  integer   :: ni, nj
+
+  if (size($X,kind=8) <= 8388608_8) then
+    ni = size($X,kind=4)
+    nj = 1
+  else
+    ni = 8388608
+    nj = int(size($X,kind=8)/8388608_8,4) + 1
+  endif
+  rc8 = zmq_get_cdmatrix(zmq_to_qp_run_socket, 1, '$X', $X, ni, nj, size($X,kind=8) )
+  zmq_get_$X = rc8
+end
+
+SUBST [ X ]
+
+psi_coef_complex ;;
+psi_bilinear_matrix_values_complex ;;
+
+END_TEMPLATE
+
 
 !---------------------------------------------------------------------------
 

src/fci/fci.irp.f

@@ -37,7 +37,11 @@ program fci
   END_DOC
 
   if (.not.is_zmq_slave) then
-    PROVIDE psi_det psi_coef mo_two_e_integrals_in_map
+    if (is_complex) then
+      PROVIDE psi_det psi_coef_complex mo_two_e_integrals_in_map
+    else
+      PROVIDE psi_det psi_coef mo_two_e_integrals_in_map
+    endif
 
     if (do_pt2) then
       call run_stochastic_cipsi

src/generators_cas/generators.irp.f

@@ -82,3 +82,39 @@ BEGIN_PROVIDER [ double precision, select_max, (size_select_max) ]
   select_max = huge(1.d0)
 END_PROVIDER
 
+
+ BEGIN_PROVIDER [ complex*16, psi_coef_generators_complex, (psi_det_size,N_states) ]
+&BEGIN_PROVIDER [ complex*16, psi_coef_sorted_gen_complex, (psi_det_size,N_states) ]
+  implicit none
+  BEGIN_DOC
+  ! For Single reference wave functions, the generator 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(:)
+  integer :: inongen
+
+  allocate(nongen(N_det))
+
+  inongen = 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_coef_generators_complex(m,:) = psi_coef_sorted_complex(i,:)
+    else
+      inongen += 1
+      nongen(inongen) = i
+    endif
+  enddo
+  ASSERT (m == N_det_generators)
+
+  psi_coef_sorted_gen_complex(:N_det_generators, :) = psi_coef_generators_complex(:N_det_generators, :)
+  do i=1,inongen
+    psi_coef_sorted_gen_complex(N_det_generators+i, :) = psi_coef_sorted_complex(nongen(i),:)
+  end do
+END_PROVIDER
+

src/generators_full/generators.irp.f

@@ -22,20 +22,35 @@ BEGIN_PROVIDER [ integer, N_det_generators ]
  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) ]
+BEGIN_PROVIDER [ integer(bit_kind), psi_det_generators, (N_int,2,psi_det_size) ]
  implicit none
  BEGIN_DOC
  ! For Single reference wave functions, the generator is the
  ! Hartree-Fock determinant
  END_DOC
  psi_det_generators(1:N_int,1:2,1:N_det) = psi_det_sorted(1:N_int,1:2,1:N_det)
- psi_coef_generators(1:N_det,1:N_states) = psi_coef_sorted(1:N_det,1:N_states)
 
 END_PROVIDER
 
+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
+ psi_coef_generators(1:N_det,1:N_states) = psi_coef_sorted(1:N_det,1:N_states)
+END_PROVIDER
+
+BEGIN_PROVIDER [ complex*16, psi_coef_generators_complex, (psi_det_size,N_states) ]
+ implicit none
+ BEGIN_DOC
+ ! For Single reference wave functions, the generator is the
+ ! Hartree-Fock determinant
+ END_DOC
+ psi_coef_generators_complex(1:N_det,1:N_states) = psi_coef_sorted_complex(1:N_det,1:N_states)
+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
@@ -44,10 +59,26 @@ END_PROVIDER
  ! Hartree-Fock determinant
  END_DOC
  psi_det_sorted_gen = psi_det_sorted
- psi_coef_sorted_gen = psi_coef_sorted
  psi_det_sorted_gen_order = psi_det_sorted_order
 END_PROVIDER
 
+BEGIN_PROVIDER [ double precision, psi_coef_sorted_gen, (psi_det_size,N_states) ]
+ implicit none
+ BEGIN_DOC
+ ! For Single reference wave functions, the generator is the
+ ! Hartree-Fock determinant
+ END_DOC
+ psi_coef_sorted_gen = psi_coef_sorted
+END_PROVIDER
+
+BEGIN_PROVIDER [ complex*16, psi_coef_sorted_gen_complex, (psi_det_size,N_states) ]
+ implicit none
+ BEGIN_DOC
+ ! For Single reference wave functions, the generator is the
+ ! Hartree-Fock determinant
+ END_DOC
+ psi_coef_sorted_gen_complex = psi_coef_sorted_complex
+END_PROVIDER
 
 BEGIN_PROVIDER [integer, degree_max_generators]
  implicit none

src/hartree_fock/hf_energy.irp.f

@@ -11,24 +11,52 @@ BEGIN_PROVIDER [double precision, extra_e_contrib_density]
 
 END_PROVIDER
 
- BEGIN_PROVIDER [ double precision, HF_energy]
-&BEGIN_PROVIDER [ double precision, HF_two_electron_energy]
-&BEGIN_PROVIDER [ double precision, HF_one_electron_energy]
+ BEGIN_PROVIDER [ double precision, hf_energy]
+&BEGIN_PROVIDER [ double precision, hf_two_electron_energy]
+&BEGIN_PROVIDER [ double precision, hf_one_electron_energy]
  implicit none
  BEGIN_DOC
  ! Hartree-Fock energy containing the nuclear repulsion, and its one- and two-body components.
  END_DOC
- integer :: i,j
- HF_energy = nuclear_repulsion
- HF_two_electron_energy = 0.d0
- HF_one_electron_energy = 0.d0
- do j=1,ao_num
-   do i=1,ao_num
-    HF_two_electron_energy += 0.5d0 * ( ao_two_e_integral_alpha(i,j) * SCF_density_matrix_ao_alpha(i,j) &
-                                       +ao_two_e_integral_beta(i,j)  * SCF_density_matrix_ao_beta(i,j) )
-    HF_one_electron_energy += ao_one_e_integrals(i,j) * (SCF_density_matrix_ao_alpha(i,j) + SCF_density_matrix_ao_beta (i,j) )
-   enddo
- enddo
- HF_energy += HF_two_electron_energy + HF_one_electron_energy
+ integer :: i,j,k
+ hf_energy = nuclear_repulsion
+ hf_two_electron_energy = 0.d0
+ hf_one_electron_energy = 0.d0
+  if (is_complex) then
+    complex*16 :: hf_1e_tmp, hf_2e_tmp
+    hf_1e_tmp = (0.d0,0.d0)
+    hf_2e_tmp = (0.d0,0.d0)
+    do k=1,kpt_num
+      do j=1,ao_num_per_kpt
+        do i=1,ao_num_per_kpt
+          hf_2e_tmp += 0.5d0 * ( ao_two_e_integral_alpha_kpts(i,j,k) * scf_density_matrix_ao_alpha_kpts(j,i,k) &
+                                +ao_two_e_integral_beta_kpts(i,j,k)  * scf_density_matrix_ao_beta_kpts(j,i,k) )
+          hf_1e_tmp += ao_one_e_integrals_kpts(i,j,k) * (scf_density_matrix_ao_alpha_kpts(j,i,k) &
+                                                        + scf_density_matrix_ao_beta_kpts (j,i,k) )
+        enddo
+      enddo
+    enddo
+    if (dabs(dimag(hf_2e_tmp)).gt.1.d-10) then
+      print*,'HF_2e energy should be real:',irp_here
+      stop -1
+    else
+      hf_two_electron_energy = dble(hf_2e_tmp)
+    endif
+    if (dabs(dimag(hf_1e_tmp)).gt.1.d-10) then
+      print*,'HF_1e energy should be real:',irp_here
+      stop -1
+    else
+      hf_one_electron_energy = dble(hf_1e_tmp)
+    endif
+  else
+    do j=1,ao_num
+      do i=1,ao_num
+        hf_two_electron_energy += 0.5d0 * ( ao_two_e_integral_alpha(i,j) * scf_density_matrix_ao_alpha(i,j) &
+                                           +ao_two_e_integral_beta(i,j)  * scf_density_matrix_ao_beta(i,j) )
+        hf_one_electron_energy += ao_one_e_integrals(i,j) * (scf_density_matrix_ao_alpha(i,j) + scf_density_matrix_ao_beta (i,j) )
+      enddo
+    enddo
+  endif
+ hf_energy += hf_two_electron_energy + hf_one_electron_energy
 END_PROVIDER
 

src/hartree_fock/print_e_scf.irp.f

@@ -0,0 +1,19 @@
+program print_e_scf
+  call run
+end
+
+subroutine run
+
+  use bitmasks
+  implicit none
+
+  call print_debug_scf_complex
+
+  print*,'hf 1e,2e,total energy'
+  print*,hf_one_electron_energy
+  print*,hf_two_electron_energy
+  print*,hf_energy
+  
+end
+
+

src/hartree_fock/scf.irp.f

@@ -45,19 +45,43 @@ subroutine create_guess
   END_DOC
   logical                        :: exists
   PROVIDE ezfio_filename
-  call ezfio_has_mo_basis_mo_coef(exists)
+  if (is_complex) then
+!    call ezfio_has_mo_basis_mo_coef_complex(exists)
+    call ezfio_has_mo_basis_mo_coef_kpts(exists)
+  else
+    call ezfio_has_mo_basis_mo_coef(exists)
+  endif
   if (.not.exists) then
     if (mo_guess_type == "HCore") then
-      mo_coef = ao_ortho_lowdin_coef
-      TOUCH mo_coef
-      mo_label = 'Guess'
-      call mo_as_eigvectors_of_mo_matrix(mo_one_e_integrals,     &
-          size(mo_one_e_integrals,1),                            &
-          size(mo_one_e_integrals,2),                            &
-          mo_label,1,.false.)
-      SOFT_TOUCH mo_coef mo_label
+      if (is_complex) then
+        !mo_coef_complex = ao_ortho_lowdin_coef_complex
+        mo_coef_kpts = ao_ortho_lowdin_coef_kpts
+        TOUCH mo_coef_kpts
+        mo_label = 'Guess'
+        !call mo_as_eigvectors_of_mo_matrix_complex(mo_one_e_integrals_kpts,     &
+        call mo_as_eigvectors_of_mo_matrix_kpts(mo_one_e_integrals_kpts,     &
+            size(mo_one_e_integrals_kpts,1),                            &
+            size(mo_one_e_integrals_kpts,2),                            &
+            size(mo_one_e_integrals_kpts,3),                            &
+            mo_label,1,.false.)
+        SOFT_TOUCH mo_coef_kpts mo_label
+      else
+        mo_coef = ao_ortho_lowdin_coef
+        TOUCH mo_coef
+        mo_label = 'Guess'
+        call mo_as_eigvectors_of_mo_matrix(mo_one_e_integrals,     &
+            size(mo_one_e_integrals,1),                            &
+            size(mo_one_e_integrals,2),                            &
+            mo_label,1,.false.)
+        SOFT_TOUCH mo_coef mo_label
+      endif
     else if (mo_guess_type == "Huckel") then
-      call huckel_guess
+      if (is_complex) then
+        !call huckel_guess_complex
+        call huckel_guess_kpts
+      else
+        call huckel_guess
+      endif
     else
       print *,  'Unrecognized MO guess type : '//mo_guess_type
       stop 1
@@ -77,9 +101,17 @@ subroutine run
   integer                        :: i_it, i, j, k
 
   mo_label = "Orthonormalized"
-
-  call Roothaan_Hall_SCF
+  if (is_complex) then
+    !call roothaan_hall_scf_complex
+    call roothaan_hall_scf_kpts
+  else
+    call roothaan_hall_scf
+  endif
   call ezfio_set_hartree_fock_energy(SCF_energy)
+  print*,'hf 1e,2e,total energy'
+  print*,hf_one_electron_energy
+  print*,hf_two_electron_energy
+  print*,hf_energy
 
 end
 

src/iterations/print_summary.irp.f

@@ -102,3 +102,15 @@ subroutine print_summary(e_,pt2_,error_,variance_,norm_,n_det_,n_occ_pattern_,n_
 
 end subroutine
 
+subroutine print_debug_fci
+  implicit none
+  integer :: i 
+  do i=1,n_det
+    print'(2((F25.15),2X))',psi_coef_complex(i,1)
+    call debug_det(psi_det(1,1,i),n_int)
+  enddo
+  print*,'hamiltonian'
+  do i=1,n_det
+    print '(1000(F25.15))',h_matrix_all_dets_complex(i,:)
+  enddo
+end subroutine

src/mo_basis/EZFIO.cfg

@@ -9,6 +9,18 @@ doc: Coefficient of the i-th |AO| on the j-th |MO|
 interface: ezfio
 size: (ao_basis.ao_num,mo_basis.mo_num)
 
+[mo_coef_complex]
+type: double precision
+doc: Complex MO coefficient of the i-th |AO| on the j-th |MO|
+interface: ezfio
+size: (2,ao_basis.ao_num,mo_basis.mo_num)
+
+[mo_coef_kpts]
+type: double precision
+doc: Complex MO coefficient of the i-th |AO| on the j-th |MO|
+interface: ezfio
+size: (2,ao_basis.ao_num_per_kpt,mo_basis.mo_num_per_kpt,nuclei.kpt_num)
+
 [mo_label]
 type: character*(64)
 doc: Label characterizing the MOS (Local, Canonical, Natural, *etc*)
@@ -20,6 +32,12 @@ doc: |MO| occupation numbers
 interface: ezfio
 size: (mo_basis.mo_num)
 
+[mo_occ_kpts]
+type: double precision
+doc: |MO| occupation numbers
+interface: ezfio
+size: (mo_basis.mo_num_per_kpt,nuclei.kpt_num)
+
 [mo_class]
 type: MO_class
 doc: [ Core | Inactive | Active | Virtual | Deleted ], as defined by :ref:`qp_set_mo_class`
@@ -31,3 +49,9 @@ type: character*(32)
 doc: MD5 checksum characterizing the |AO| basis set.
 interface: ezfio
 
+[mo_num_per_kpt]
+type: integer
+doc: Number of |MOs| per kpt
+default: =(mo_basis.mo_num/nuclei.kpt_num)
+interface: ezfio
+

src/mo_basis/NEED

@@ -1,3 +1,3 @@
 ao_basis
-ao_one_e_ints
 electrons
+ao_one_e_ints

src/mo_basis/mos.irp.f

@@ -101,7 +101,7 @@ BEGIN_PROVIDER [ double precision, mo_coef_in_ao_ortho_basis, (ao_num, mo_num) ]
  ! $C^{-1}.C_{mo}$
  END_DOC
  call dgemm('N','N',ao_num,mo_num,ao_num,1.d0,                   &
-     ao_ortho_canonical_coef_inv, size(ao_ortho_canonical_coef_inv,1),&
+     ao_ortho_cano_coef_inv, size(ao_ortho_cano_coef_inv,1),&
      mo_coef, size(mo_coef,1), 0.d0,                                 &
      mo_coef_in_ao_ortho_basis, size(mo_coef_in_ao_ortho_basis,1))
 
@@ -242,28 +242,43 @@ subroutine mix_mo_jk(j,k)
   ! by convention, the '+' |MO| is in the lowest  index (min(j,k))
   ! by convention, the '-' |MO| is in the highest index (max(j,k))
   END_DOC
-  double precision               :: array_tmp(ao_num,2),dsqrt_2
   if(j==k)then
     print*,'You want to mix two orbitals that are the same !'
     print*,'It does not make sense ... '
     print*,'Stopping ...'
     stop
   endif
-  array_tmp = 0.d0
+  double precision               :: dsqrt_2
   dsqrt_2 = 1.d0/dsqrt(2.d0)
-  do i = 1, ao_num
-    array_tmp(i,1) = dsqrt_2 * (mo_coef(i,j) + mo_coef(i,k))
-    array_tmp(i,2) = dsqrt_2 * (mo_coef(i,j) - mo_coef(i,k))
-  enddo
   i_plus = min(j,k)
   i_minus = max(j,k)
-  do i = 1, ao_num
-    mo_coef(i,i_plus) = array_tmp(i,1)
-    mo_coef(i,i_minus) = array_tmp(i,2)
-  enddo
+  if (is_complex) then
+    complex*16               :: array_tmp_c(ao_num,2)
+    array_tmp_c = (0.d0,0.d0)
+    do i = 1, ao_num
+      array_tmp_c(i,1) = dsqrt_2 * (mo_coef_complex(i,j) + mo_coef_complex(i,k))
+      array_tmp_c(i,2) = dsqrt_2 * (mo_coef_complex(i,j) - mo_coef_complex(i,k))
+    enddo
+    do i = 1, ao_num
+      mo_coef_complex(i,i_plus) = array_tmp_c(i,1)
+      mo_coef_complex(i,i_minus) = array_tmp_c(i,2)
+    enddo
+  else
+    double precision               :: array_tmp(ao_num,2)
+    array_tmp = 0.d0
+    do i = 1, ao_num
+      array_tmp(i,1) = dsqrt_2 * (mo_coef(i,j) + mo_coef(i,k))
+      array_tmp(i,2) = dsqrt_2 * (mo_coef(i,j) - mo_coef(i,k))
+    enddo
+    do i = 1, ao_num
+      mo_coef(i,i_plus) = array_tmp(i,1)
+      mo_coef(i,i_minus) = array_tmp(i,2)
+    enddo
+  endif
 
 end
 
+
 subroutine ao_ortho_cano_to_ao(A_ao,LDA_ao,A,LDA)
   implicit none
   BEGIN_DOC
@@ -280,13 +295,13 @@ subroutine ao_ortho_cano_to_ao(A_ao,LDA_ao,A,LDA)
 
   call dgemm('T','N', ao_num, ao_num, ao_num,                        &
       1.d0,                                                          &
-      ao_ortho_canonical_coef_inv, size(ao_ortho_canonical_coef_inv,1),&
+      ao_ortho_cano_coef_inv, size(ao_ortho_cano_coef_inv,1),&
       A_ao,size(A_ao,1),                                             &
       0.d0, T, size(T,1))
 
   call dgemm('N','N', ao_num, ao_num, ao_num, 1.d0,                  &
       T, size(T,1),                                                  &
-      ao_ortho_canonical_coef_inv,size(ao_ortho_canonical_coef_inv,1),&
+      ao_ortho_cano_coef_inv,size(ao_ortho_cano_coef_inv,1),&
       0.d0, A, size(A,1))
 
   deallocate(T)

src/mo_basis/mos_cplx.irp.f

@@ -0,0 +1,481 @@
+BEGIN_PROVIDER [ integer, mo_num_per_kpt ]
+ implicit none
+ BEGIN_DOC
+ ! number of mos per kpt.
+ END_DOC
+ mo_num_per_kpt = mo_num/kpt_num
+END_PROVIDER
+
+BEGIN_PROVIDER [ complex*16, mo_coef_complex, (ao_num,mo_num) ]
+  implicit none
+  BEGIN_DOC
+  ! Molecular orbital coefficients on |AO| basis set
+  !
+  ! mo_coef_imag(i,j) = coefficient of the i-th |AO| on the jth |MO|
+  !
+  ! mo_label : Label characterizing the |MOs| (local, canonical, natural, etc)
+  END_DOC
+  integer                        :: i, j
+  logical                        :: exists
+  PROVIDE ezfio_filename
+
+  if (mpi_master) then
+    ! Coefs
+    call ezfio_has_mo_basis_mo_coef_complex(exists)
+  endif
+  IRP_IF MPI_DEBUG
+    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(exists, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr)
+    if (ierr /= MPI_SUCCESS) then
+      stop 'Unable to read mo_coef_complex with MPI'
+    endif
+  IRP_ENDIF
+  
+  if (exists) then
+    if (mpi_master) then
+      call ezfio_get_mo_basis_mo_coef_complex(mo_coef_complex)
+      write(*,*) 'Read  mo_coef_complex'
+    endif
+    IRP_IF MPI
+      call MPI_BCAST( mo_coef_complex, mo_num*ao_num, MPI_DOUBLE_COMPLEX, 0, MPI_COMM_WORLD, ierr)
+      if (ierr /= MPI_SUCCESS) then
+        stop 'Unable to read mo_coef_complex with MPI'
+      endif
+    IRP_ENDIF
+  else
+    ! Orthonormalized AO basis
+    do i=1,mo_num
+      do j=1,ao_num
+        mo_coef_complex(j,i) = ao_ortho_canonical_coef_complex(j,i)
+      enddo
+    enddo
+  endif
+END_PROVIDER
+
+
+BEGIN_PROVIDER [ complex*16, mo_coef_in_ao_ortho_basis_complex, (ao_num, mo_num) ]
+ implicit none
+ BEGIN_DOC
+ ! |MO| coefficients in orthogonalized |AO| basis
+ !
+ ! $C^{-1}.C_{mo}$
+ END_DOC
+ call zgemm('N','N',ao_num,mo_num,ao_num,(1.d0,0.d0),                   &
+     ao_ortho_cano_coef_inv_cplx, size(ao_ortho_cano_coef_inv_cplx,1),&
+     mo_coef_complex, size(mo_coef_complex,1), (0.d0,0.d0),                                 &
+     mo_coef_in_ao_ortho_basis_complex, size(mo_coef_in_ao_ortho_basis_complex,1))
+
+END_PROVIDER
+
+BEGIN_PROVIDER [ complex*16, mo_coef_complex_kpts, (ao_num_per_kpt, mo_num_per_kpt, kpt_num) ]
+  implicit none
+  BEGIN_DOC
+  ! nonzero blocks of |MO| coefficients
+  !
+  END_DOC
+  integer :: i,j,k, mo_shft, ao_shft
+  mo_coef_complex_kpts = (0.d0,0.d0)
+
+ ! do k=1,kpt_num
+ !   mo_shft = (k-1)*mo_num_per_kpt
+ !   ao_shft = (k-1)*ao_num_per_kpt
+ !   do i=1,mo_num_per_kpt
+ !     do j=1,ao_num_per_kpt
+ !       mo_coef_complex_kpts(j,i,k) = mo_coef_complex(j+ao_shft,i+mo_shft)
+ !     enddo
+ !   enddo
+ ! enddo
+  do k=1,kpt_num
+    do i=1,mo_num_per_kpt
+      do j=1,ao_num_per_kpt
+        mo_coef_complex_kpts(j,i,k) = mo_coef_kpts(j,i,k)
+      enddo
+    enddo
+  enddo
+
+END_PROVIDER
+
+
+ BEGIN_PROVIDER [ complex*16, mo_coef_transp_complex, (mo_num,ao_num) ]
+&BEGIN_PROVIDER [ complex*16, mo_coef_transp_complex_conjg, (mo_num,ao_num) ]
+  implicit none
+  BEGIN_DOC
+  ! |MO| coefficients on |AO| basis set
+  END_DOC
+  integer                        :: i, j
+
+  do j=1,ao_num
+    do i=1,mo_num
+      mo_coef_transp_complex(i,j) = mo_coef_complex(j,i)
+      mo_coef_transp_complex_conjg(i,j) = dconjg(mo_coef_complex(j,i))
+    enddo
+  enddo
+
+END_PROVIDER
+
+subroutine ao_to_mo_complex(A_ao,LDA_ao,A_mo,LDA_mo)
+  implicit none
+  BEGIN_DOC
+  ! Transform A from the AO basis to the MO basis
+  ! where A is complex in the AO basis
+  !
+  ! C^\dagger.A_ao.C
+  END_DOC
+  integer, intent(in)            :: LDA_ao,LDA_mo
+  complex*16, intent(in)   :: A_ao(LDA_ao,ao_num)
+  complex*16, intent(out)  :: A_mo(LDA_mo,mo_num)
+  complex*16, allocatable  :: T(:,:)
+  
+  allocate ( T(ao_num,mo_num) )
+  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
+  
+  call zgemm('N','N', ao_num, mo_num, ao_num,                    &
+      (1.d0,0.d0), A_ao,LDA_ao,                                      &
+      mo_coef_complex, size(mo_coef_complex,1),                                      &
+      (0.d0,0.d0), T, size(T,1))
+  
+  call zgemm('C','N', mo_num, mo_num, ao_num,                &
+      (1.d0,0.d0), mo_coef_complex,size(mo_coef_complex,1),                          &
+      T, ao_num,                                                     &   
+      (0.d0,0.d0), A_mo, size(A_mo,1))
+  
+  deallocate(T)
+end
+
+subroutine ao_to_mo_noconjg_complex(A_ao,LDA_ao,A_mo,LDA_mo)
+  implicit none
+  BEGIN_DOC
+  ! Transform A from the AO basis to the MO basis
+  ! where A is complex in the AO basis
+  !
+  ! C^T.A_ao.C
+  ! needed for 4idx tranform in four_idx_novvvv
+  END_DOC
+  integer, intent(in)            :: LDA_ao,LDA_mo
+  complex*16, intent(in)   :: A_ao(LDA_ao,ao_num)
+  complex*16, intent(out)  :: A_mo(LDA_mo,mo_num)
+  complex*16, allocatable  :: T(:,:)
+  
+  allocate ( T(ao_num,mo_num) )
+  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
+  
+  call zgemm('N','N', ao_num, mo_num, ao_num,                    &
+      (1.d0,0.d0), A_ao,LDA_ao,                                      &
+      mo_coef_complex, size(mo_coef_complex,1),                                      &
+      (0.d0,0.d0), T, size(T,1))
+  
+  call zgemm('T','N', mo_num, mo_num, ao_num,                &
+      (1.d0,0.d0), mo_coef_complex,size(mo_coef_complex,1),                          &
+      T, ao_num,                                                     &   
+      (0.d0,0.d0), A_mo, size(A_mo,1))
+  
+  deallocate(T)
+end
+
+
+subroutine ao_ortho_cano_to_ao_cplx(A_ao,LDA_ao,A,LDA)
+  implicit none
+  BEGIN_DOC
+  ! Transform A from the |AO| basis to the orthogonal |AO| basis
+  !
+  ! $C^{-1}.A_{ao}.C^{\dagger-1}$
+  END_DOC
+  integer, intent(in)            :: LDA_ao,LDA
+  complex*16, intent(in)   :: A_ao(LDA_ao,*)
+  complex*16, intent(out)  :: A(LDA,*)
+  complex*16, allocatable  :: T(:,:)
+
+  allocate ( T(ao_num,ao_num) )
+
+  call zgemm('C','N', ao_num, ao_num, ao_num,                        &
+      (1.d0,0.d0),                                                     &
+      ao_ortho_cano_coef_inv_cplx, size(ao_ortho_cano_coef_inv_cplx,1),&
+      A_ao,size(A_ao,1),                                             &
+      (0.d0,0.d0), T, size(T,1))
+
+  call zgemm('N','N', ao_num, ao_num, ao_num, (1.d0,0.d0),             &
+      T, size(T,1),                                                  &
+      ao_ortho_cano_coef_inv_cplx,size(ao_ortho_cano_coef_inv_cplx,1),&
+      (0.d0,0.d0), A, size(A,1))
+
+  deallocate(T)
+end
+
+!============================================!
+!                                            !
+!                    kpts                    !
+!                                            !
+!============================================!
+
+
+BEGIN_PROVIDER [ complex*16, mo_coef_kpts, (ao_num_per_kpt, mo_num_per_kpt, kpt_num) ]
+  implicit none
+  BEGIN_DOC
+  ! Molecular orbital coefficients on |AO| basis set
+  !
+  ! mo_coef_kpts(i,j,k) = coefficient of the i-th |AO| on the jth |MO| in kth kpt
+  !
+  ! mo_label : Label characterizing the |MOs| (local, canonical, natural, etc)
+  END_DOC
+  integer                        :: i, j, k
+  logical                        :: exists
+  PROVIDE ezfio_filename
+
+  if (mpi_master) then
+    ! Coefs
+    call ezfio_has_mo_basis_mo_coef_kpts(exists)
+  endif
+  IRP_IF MPI_DEBUG
+    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(exists, 1, MPI_LOGICAL, 0, MPI_COMM_WORLD, ierr)
+    if (ierr /= MPI_SUCCESS) then
+      stop 'Unable to read mo_coef_kpts with MPI'
+    endif
+  IRP_ENDIF
+  
+  if (exists) then
+    if (mpi_master) then
+      call ezfio_get_mo_basis_mo_coef_kpts(mo_coef_kpts)
+      write(*,*) 'Read  mo_coef_kpts'
+    endif
+    IRP_IF MPI
+      call MPI_BCAST( mo_coef_kpts, kpt_num*mo_num_per_kpt*ao_num_per_kpt, MPI_DOUBLE_COMPLEX, 0, MPI_COMM_WORLD, ierr)
+      if (ierr /= MPI_SUCCESS) then
+        stop 'Unable to read mo_coef_kpts with MPI'
+      endif
+    IRP_ENDIF
+  else
+    ! Orthonormalized AO basis
+
+    do k=1,kpt_num
+      do i=1,mo_num_per_kpt
+        do j=1,ao_num_per_kpt
+          mo_coef_kpts(j,i,k) = ao_ortho_canonical_coef_kpts(j,i,k)
+        enddo
+      enddo
+    enddo
+  endif
+END_PROVIDER
+
+BEGIN_PROVIDER [ complex*16, mo_coef_in_ao_ortho_basis_kpts, (ao_num_per_kpt, mo_num_per_kpt, kpt_num) ]
+ implicit none
+ BEGIN_DOC
+ ! |MO| coefficients in orthogonalized |AO| basis
+ !
+ ! $C^{-1}.C_{mo}$
+ END_DOC
+ integer :: k
+ do k=1,kpt_num
+
+   call zgemm('N','N',ao_num_per_kpt,mo_num_per_kpt,ao_num_per_kpt,(1.d0,0.d0),                   &
+       ao_ortho_cano_coef_inv_kpts(:,:,k), size(ao_ortho_cano_coef_inv_kpts,1),&
+       mo_coef_kpts(:,:,k), size(mo_coef_kpts,1), (0.d0,0.d0),                                 &
+       mo_coef_in_ao_ortho_basis_kpts(:,:,k), size(mo_coef_in_ao_ortho_basis_kpts,1))
+ enddo
+
+END_PROVIDER
+
+ BEGIN_PROVIDER [ complex*16, mo_coef_transp_kpts, (mo_num_per_kpt,ao_num_per_kpt,kpt_num) ]
+&BEGIN_PROVIDER [ complex*16, mo_coef_transp_kpts_conjg, (mo_num_per_kpt,ao_num_per_kpt,kpt_num) ]
+  implicit none
+  BEGIN_DOC
+  ! |MO| coefficients on |AO| basis set
+  END_DOC
+  integer                        :: i, j, k
+
+  do k=1,kpt_num
+    do j=1,ao_num_per_kpt
+      do i=1,mo_num_per_kpt
+        mo_coef_transp_kpts(i,j,k) = mo_coef_kpts(j,i,k)
+        mo_coef_transp_kpts_conjg(i,j,k) = dconjg(mo_coef_kpts(j,i,k))
+      enddo
+    enddo
+  enddo
+
+END_PROVIDER
+
+subroutine ao_to_mo_kpts(A_ao,LDA_ao,A_mo,LDA_mo)
+  implicit none
+  !todo: check this
+  BEGIN_DOC
+  ! Transform A from the AO basis to the MO basis
+  ! where A is complex in the AO basis
+  !
+  ! C^\dagger.A_ao.C
+  END_DOC
+  integer, intent(in)            :: LDA_ao,LDA_mo
+  complex*16, intent(in)   :: A_ao(LDA_ao,ao_num_per_kpt,kpt_num)
+  complex*16, intent(out)  :: A_mo(LDA_mo,mo_num_per_kpt,kpt_num)
+  complex*16, allocatable  :: T(:,:)
+  
+  allocate ( T(ao_num_per_kpt,mo_num_per_kpt) )
+  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
+  integer :: k
+
+  do k=1,kpt_num
+    call zgemm('N','N', ao_num_per_kpt, mo_num_per_kpt, ao_num_per_kpt,   &
+        (1.d0,0.d0), A_ao(:,:,k),LDA_ao,                                      &
+        mo_coef_kpts(:,:,k), size(mo_coef_kpts,1),                                      &
+        (0.d0,0.d0), T, size(T,1))
+    
+    call zgemm('C','N', mo_num_per_kpt, mo_num_per_kpt, ao_num_per_kpt,    &
+        (1.d0,0.d0), mo_coef_kpts(:,:,k),size(mo_coef_kpts,1),             &
+        T, ao_num_per_kpt,                                                     &   
+        (0.d0,0.d0), A_mo(:,:,k), size(A_mo,1))
+  enddo
+  
+  deallocate(T)
+end
+
+subroutine ao_to_mo_noconjg_kpts(A_ao,LDA_ao,A_mo,LDA_mo)
+  implicit none
+  BEGIN_DOC
+  ! Transform A from the AO basis to the MO basis
+  ! where A is complex in the AO basis
+  !
+  ! C^T.A_ao.C
+  ! needed for 4idx tranform in four_idx_novvvv
+  END_DOC
+  integer, intent(in)            :: LDA_ao,LDA_mo
+  complex*16, intent(in)   :: A_ao(LDA_ao,ao_num_per_kpt,kpt_num)
+  complex*16, intent(out)  :: A_mo(LDA_mo,mo_num_per_kpt,kpt_num)
+  complex*16, allocatable  :: T(:,:)
+  
+  allocate ( T(ao_num_per_kpt,mo_num_per_kpt) )
+  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
+  integer :: k
+  do k=1,kpt_num
+    call zgemm('N','N', ao_num_per_kpt, mo_num_per_kpt, ao_num_per_kpt, &
+        (1.d0,0.d0), A_ao,LDA_ao,                                      &
+        mo_coef_kpts(:,:,k), size(mo_coef_kpts,1),                                      &
+        (0.d0,0.d0), T, size(T,1))
+    
+    call zgemm('T','N', mo_num_per_kpt, mo_num_per_kpt, ao_num_per_kpt, &
+        (1.d0,0.d0), mo_coef_kpts(:,:,k),size(mo_coef_kpts,1),            &
+        T, ao_num_per_kpt,                                                     &   
+        (0.d0,0.d0), A_mo(:,:,k), size(A_mo,1))
+  enddo 
+  deallocate(T)
+end
+
+
+subroutine ao_ortho_cano_to_ao_kpts(A_ao,LDA_ao,A,LDA)
+  implicit none
+  !todo: check this; no longer using assumed-size arrays
+  BEGIN_DOC
+  ! Transform A from the |AO| basis to the orthogonal |AO| basis
+  !
+  ! $C^{-1}.A_{ao}.C^{\dagger-1}$
+  END_DOC
+  integer, intent(in)            :: LDA_ao,LDA
+  complex*16, intent(in)   :: A_ao(LDA_ao,ao_num_per_kpt,kpt_num)
+  complex*16, intent(out)  :: A(LDA,ao_num_per_kpt,kpt_num)
+  complex*16, allocatable  :: T(:,:)
+
+  allocate ( T(ao_num_per_kpt,ao_num_per_kpt) )
+
+  integer :: k
+  do k=1,kpt_num
+    call zgemm('C','N', ao_num_per_kpt, ao_num_per_kpt, ao_num_per_kpt,                        &
+        (1.d0,0.d0),                                                     &
+        ao_ortho_cano_coef_inv_kpts(:,:,k), size(ao_ortho_cano_coef_inv_kpts,1),&
+        A_ao(:,:,k),size(A_ao,1),                                             &
+        (0.d0,0.d0), T, size(T,1))
+
+    call zgemm('N','N', ao_num_per_kpt, ao_num_per_kpt, ao_num_per_kpt, (1.d0,0.d0),             &
+        T, size(T,1),                                                  &
+        ao_ortho_cano_coef_inv_kpts(:,:,k),size(ao_ortho_cano_coef_inv_kpts,1),&
+        (0.d0,0.d0), A(:,:,k), size(A,1))
+  enddo
+
+  deallocate(T)
+end
+
+
+!============================================!
+!                                            !
+!               elec kpts                    !
+!                                            !
+!============================================!
+
+ BEGIN_PROVIDER [ integer, elec_alpha_num_kpts, (kpt_num) ]
+&BEGIN_PROVIDER [ integer, elec_beta_num_kpts, (kpt_num) ]
+  !todo: reorder? if not integer multiple, use some list of kpts to determine filling order
+  implicit none
+ 
+  integer :: i,k,kpt
+
+  PROVIDE elec_alpha_num elec_beta_num
+
+  do k=1,kpt_num
+    elec_alpha_num_kpts(k) = 0
+    elec_beta_num_kpts(k) = 0
+  enddo
+  kpt=1
+  do i=1,elec_beta_num
+    elec_alpha_num_kpts(kpt) += 1
+    elec_beta_num_kpts(kpt) += 1
+    kpt += 1
+    if (kpt > kpt_num) then
+      kpt = 1
+    endif
+  enddo
+  do i=elec_beta_num+1,elec_alpha_num
+    elec_alpha_num_kpts(kpt) += 1
+    kpt += 1
+    if (kpt > kpt_num) then
+      kpt = 1
+    endif
+  enddo
+
+END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, mo_occ_kpts, (mo_num_per_kpt,kpt_num) ]
+  implicit none
+  BEGIN_DOC
+  ! |MO| occupation numbers
+  END_DOC
+  PROVIDE ezfio_filename elec_beta_num_kpts elec_alpha_num_kpts
+  if (mpi_master) then
+    logical :: exists
+    call ezfio_has_mo_basis_mo_occ_kpts(exists)
+    if (exists) then
+      call ezfio_get_mo_basis_mo_occ_kpts(mo_occ_kpts)
+    else
+      mo_occ_kpts = 0.d0
+      integer :: i,k
+      do k=1,kpt_num
+        do i=1,elec_beta_num_kpts(k)
+          mo_occ_kpts(i,k) = 2.d0
+        enddo
+        do i=elec_beta_num_kpts(k)+1,elec_alpha_num_kpts(k)
+          mo_occ_kpts(i,k) = 1.d0
+        enddo
+      enddo
+    endif
+    write(*,*) 'Read mo_occ_kpts'
+  endif
+  IRP_IF MPI_DEBUG
+    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( mo_occ_kpts, mo_num_per_kpt*kpt_num, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, ierr)
+    if (ierr /= MPI_SUCCESS) then
+      stop 'Unable to read mo_occ_kpts with MPI'
+    endif
+  IRP_ENDIF
+
+END_PROVIDER

src/mo_basis/track_orb.irp.f

@@ -1,62 +0,0 @@
-BEGIN_PROVIDER [ double precision, mo_coef_begin_iteration, (ao_num,mo_num) ]
-   implicit none
-   BEGIN_DOC
-   ! Void provider to store the coefficients of the |MO| basis at the beginning of the SCF iteration
-   !
-   ! Usefull to track some orbitals
-   END_DOC
-END_PROVIDER
-
-subroutine initialize_mo_coef_begin_iteration
- implicit none
- BEGIN_DOC
- !
- ! Initialize :c:data:`mo_coef_begin_iteration` to the current :c:data:`mo_coef`
- END_DOC
- mo_coef_begin_iteration = mo_coef
-end
-
-subroutine reorder_core_orb
- implicit none
- BEGIN_DOC
-! routines that takes the current :c:data:`mo_coef` and reorder the core orbitals (see :c:data:`list_core` and :c:data:`n_core_orb`) according to the overlap with :c:data:`mo_coef_begin_iteration`
- END_DOC
- integer :: i,j,iorb
- integer :: k,l
- double precision, allocatable :: accu(:)
- integer, allocatable :: index_core_orb(:),iorder(:)
- double precision, allocatable :: mo_coef_tmp(:,:)
- allocate(accu(mo_num),index_core_orb(n_core_orb),iorder(mo_num))
- allocate(mo_coef_tmp(ao_num,mo_num))
-
- do i = 1, n_core_orb
-  iorb = list_core(i)
-  do j = 1, mo_num
-   accu(j) = 0.d0
-   iorder(j) = j
-   do k = 1, ao_num
-    do l = 1, ao_num
-     accu(j) += mo_coef_begin_iteration(k,iorb) * mo_coef(l,j) * ao_overlap(k,l)
-    enddo
-   enddo
-   accu(j) = -dabs(accu(j))
-  enddo
-  call dsort(accu,iorder,mo_num)
-  index_core_orb(i) = iorder(1)
- enddo
-
- double precision :: x
- integer :: i1,i2
- do j = 1, n_core_orb
-  i1 = list_core(j)
-  i2 = index_core_orb(j)
-  do i=1,ao_num
-    x = mo_coef(i,i1)
-    mo_coef(i,i1) = mo_coef(i,i2)
-    mo_coef(i,i2) = x
-  enddo
- enddo
-!call loc_cele_routine
-
- deallocate(accu,index_core_orb, iorder)
-end

src/mo_basis/utils.irp.f

@@ -1,23 +1,64 @@
 subroutine save_mos
   implicit none
   double precision, allocatable  :: buffer(:,:)
-  integer                        :: i,j
-
+  complex*16, allocatable        :: buffer_c(:,:),buffer_k(:,:,:)
+  integer                        :: i,j,k,ishft,jshft
+  !TODO: change this for periodic?
+  !      save real/imag parts of mo_coef_complex
+  !      otherwise need to make sure mo_coef and mo_coef_imag
+  !      are updated whenever mo_coef_complex changes
   call system('$QP_ROOT/scripts/save_current_mos.sh '//trim(ezfio_filename))
   call ezfio_set_mo_basis_mo_num(mo_num)
   call ezfio_set_mo_basis_mo_label(mo_label)
   call ezfio_set_mo_basis_ao_md5(ao_md5)
-  allocate ( buffer(ao_num,mo_num) )
-  buffer = 0.d0
-  do j = 1, mo_num
-    do i = 1, ao_num
-      buffer(i,j) = mo_coef(i,j)
+  if (is_complex) then
+    allocate ( buffer_c(ao_num,mo_num))
+    allocate ( buffer_k(ao_num_per_kpt,mo_num_per_kpt,kpt_num))
+    buffer_k = (0.d0,0.d0)
+    do k=1,kpt_num
+      do j = 1, mo_num_per_kpt
+        do i = 1, ao_num_per_kpt
+          buffer_k(i,j,k) = mo_coef_kpts(i,j,k)
+          !print*,i,j,k,buffer_k(i,j,k)
+        enddo
+      enddo
     enddo
-  enddo
-  call ezfio_set_mo_basis_mo_coef(buffer)
-  call ezfio_set_mo_basis_mo_occ(mo_occ)
+    buffer_c = (0.d0,0.d0)
+    do k=1,kpt_num
+      ishft = (k-1)*ao_num_per_kpt
+      jshft = (k-1)*mo_num_per_kpt
+      do j=1,mo_num_per_kpt
+        do i=1,ao_num_per_kpt
+          buffer_c(i+ishft,j+jshft) = buffer_k(i,j,k)
+        enddo
+      enddo
+    enddo
+    call ezfio_set_mo_basis_mo_coef_kpts(buffer_k)
+    call ezfio_set_mo_basis_mo_coef_complex(buffer_c)
+
+    deallocate (buffer_k,buffer_c)
+    mo_occ = 0.d0
+    do k=1,kpt_num
+      ishft=(k-1)*mo_num_per_kpt
+      do i=1,mo_num_per_kpt
+        mo_occ(i+ishft)=mo_occ_kpts(i,k)
+      enddo
+    enddo
+    call ezfio_set_mo_basis_mo_occ_kpts(mo_occ_kpts)
+    call ezfio_set_mo_basis_mo_occ(mo_occ)
+  else
+    allocate ( buffer(ao_num,mo_num) )
+    buffer = 0.d0
+    do j = 1, mo_num
+      do i = 1, ao_num
+        buffer(i,j) = mo_coef(i,j)
+      enddo
+    enddo
+    call ezfio_set_mo_basis_mo_coef(buffer)
+    deallocate (buffer)
+    call ezfio_set_mo_basis_mo_occ(mo_occ)
+  endif
   call ezfio_set_mo_basis_mo_class(mo_class)
-  deallocate (buffer)
 
 end
 
@@ -25,27 +66,43 @@ end
 subroutine save_mos_no_occ
   implicit none
   double precision, allocatable  :: buffer(:,:)
+  complex*16, allocatable        :: buffer_c(:,:)
   integer                        :: i,j
 
   call system('$QP_ROOT/scripts/save_current_mos.sh '//trim(ezfio_filename))
  !call ezfio_set_mo_basis_mo_num(mo_num)
  !call ezfio_set_mo_basis_mo_label(mo_label)
  !call ezfio_set_mo_basis_ao_md5(ao_md5)
-  allocate ( buffer(ao_num,mo_num) )
-  buffer = 0.d0
-  do j = 1, mo_num
-    do i = 1, ao_num
-      buffer(i,j) = mo_coef(i,j)
+  if (is_complex) then
+    print*,irp_here, ' not implemented for kpts'
+    stop -1
+    allocate ( buffer_c(ao_num,mo_num))
+    buffer_c = (0.d0,0.d0)
+    do j = 1, mo_num
+      do i = 1, ao_num
+        buffer_c(i,j) = mo_coef_complex(i,j)
+      enddo
     enddo
-  enddo
-  call ezfio_set_mo_basis_mo_coef(buffer)
-  deallocate (buffer)
+    call ezfio_set_mo_basis_mo_coef_complex(buffer_c)
+    deallocate (buffer_c)
+  else
+    allocate ( buffer(ao_num,mo_num) )
+    buffer = 0.d0
+    do j = 1, mo_num
+      do i = 1, ao_num
+        buffer(i,j) = mo_coef(i,j)
+      enddo
+    enddo
+    call ezfio_set_mo_basis_mo_coef(buffer)
+    deallocate (buffer)
+  endif
 
 end
 
 subroutine save_mos_truncated(n)
   implicit none
   double precision, allocatable  :: buffer(:,:)
+  complex*16, allocatable        :: buffer_c(:,:)
   integer                        :: i,j,n
 
   call system('$QP_ROOT/scripts/save_current_mos.sh '//trim(ezfio_filename))
@@ -53,17 +110,31 @@ subroutine save_mos_truncated(n)
   call ezfio_set_mo_basis_mo_num(n)
   call ezfio_set_mo_basis_mo_label(mo_label)
   call ezfio_set_mo_basis_ao_md5(ao_md5)
-  allocate ( buffer(ao_num,n) )
-  buffer = 0.d0
-  do j = 1, n
-    do i = 1, ao_num
-      buffer(i,j) = mo_coef(i,j)
+  if (is_complex) then
+    print*,irp_here, ' not implemented for kpts'
+    stop -1
+    allocate ( buffer_c(ao_num,mo_num))
+    buffer_c = (0.d0,0.d0)
+    do j = 1, n
+      do i = 1, ao_num
+        buffer_c(i,j) = mo_coef_complex(i,j)
+      enddo
     enddo
-  enddo
-  call ezfio_set_mo_basis_mo_coef(buffer)
+    call ezfio_set_mo_basis_mo_coef_complex(buffer_c)
+    deallocate (buffer_c)
+  else
+    allocate ( buffer(ao_num,n) )
+    buffer = 0.d0
+    do j = 1, n
+      do i = 1, ao_num
+        buffer(i,j) = mo_coef(i,j)
+      enddo
+    enddo
+    call ezfio_set_mo_basis_mo_coef(buffer)
+    deallocate (buffer)
+  endif
   call ezfio_set_mo_basis_mo_occ(mo_occ)
   call ezfio_set_mo_basis_mo_class(mo_class)
-  deallocate (buffer)
 
 end
 

src/mo_basis/utils_cplx.irp.f

@@ -0,0 +1,531 @@
+subroutine mo_as_eigvectors_of_mo_matrix_complex(matrix,n,m,label,sign,output)
+  !TODO: test this
+  implicit none
+  integer,intent(in)             :: n,m, sign
+  character*(64), intent(in)     :: label
+  complex*16, intent(in)   :: matrix(n,m)
+  logical, intent(in)            :: output
+
+  integer :: i,j
+  double precision, allocatable  :: eigvalues(:)
+  complex*16, allocatable  :: mo_coef_new(:,:), R(:,:), A(:,:)
+  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: mo_coef_new, R
+
+  call write_time(6)
+  if (m /= mo_num) then
+    print *, irp_here, ': Error : m/= mo_num'
+    stop 1
+  endif
+  allocate(A(n,m),R(n,m),mo_coef_new(ao_num,m),eigvalues(m))
+  if (sign == -1) then
+    do j=1,m
+      do i=1,n
+        A(i,j) = -matrix(i,j)
+      enddo
+    enddo
+  else
+    do j=1,m
+      do i=1,n
+        A(i,j) = matrix(i,j)
+      enddo
+    enddo
+  endif
+  mo_coef_new = mo_coef_complex
+
+  call lapack_diag_complex(eigvalues,R,A,n,m)
+  if (output) then
+    write (6,'(A)')  'MOs are now **'//trim(label)//'**'
+    write (6,'(A)') ''
+    write (6,'(A)')  'Eigenvalues'
+    write (6,'(A)') '-----------'
+    write (6,'(A)')  ''
+    write (6,'(A)') '======== ================'
+  endif
+  if (sign == -1) then
+    do i=1,m
+      eigvalues(i) = -eigvalues(i)
+    enddo
+  endif
+  if (output) then
+    do i=1,m
+      write (6,'(I8,1X,F16.10)')  i,eigvalues(i)
+    enddo
+    write (6,'(A)') '======== ================'
+    write (6,'(A)')  ''
+    !write (6,'(A)')  'Fock Matrix'
+    !write (6,'(A)') '-----------'
+    !do i=1,n
+    !  write(*,'(200(E24.15))') A(i,:)
+    !enddo
+  endif
+
+  call zgemm('N','N',ao_num,m,m,(1.d0,0.d0),mo_coef_new,size(mo_coef_new,1),R,size(R,1),(0.d0,0.d0),mo_coef_complex,size(mo_coef_complex,1))
+  deallocate(A,mo_coef_new,R,eigvalues)
+  call write_time(6)
+
+  mo_label = label
+end
+
+subroutine mo_as_svd_vectors_of_mo_matrix_complex(matrix,lda,m,n,label)
+  !TODO: test this
+  implicit none
+  integer,intent(in)             :: lda,m,n
+  character*(64), intent(in)     :: label
+  complex*16, intent(in)   :: matrix(lda,n)
+
+  integer :: i,j
+  double precision :: accu
+  double precision, allocatable  :: D(:)
+  complex*16, allocatable  :: mo_coef_new(:,:), U(:,:), A(:,:), Vt(:,:)
+  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: mo_coef_new, U, Vt, A
+
+  call write_time(6)
+  if (m /= mo_num) then
+    print *, irp_here, ': Error : m/= mo_num'
+    stop 1
+  endif
+
+  allocate(A(lda,n),U(lda,n),mo_coef_new(ao_num,m),D(m),Vt(lda,n))
+
+  do j=1,n
+    do i=1,m
+      A(i,j) = matrix(i,j)
+    enddo
+  enddo
+  mo_coef_new = mo_coef_complex
+
+  call svd_complex(A,lda,U,lda,D,Vt,lda,m,n)
+
+  write (6,'(A)') 'MOs are now **'//trim(label)//'**'
+  write (6,'(A)')  ''
+  write (6,'(A)') 'Eigenvalues'
+  write (6,'(A)')  '-----------'
+  write (6,'(A)') ''
+  write (6,'(A)')  '======== ================ ================'
+  write (6,'(A)')  '   MO       Eigenvalue       Cumulative   '
+  write (6,'(A)')  '======== ================ ================'
+
+  accu = 0.d0
+  do i=1,m
+    accu = accu + D(i)
+    write (6,'(I8,1X,F16.10,1X,F16.10)')  i,D(i), accu
+  enddo
+  write (6,'(A)')  '======== ================ ================'
+  write (6,'(A)')  ''
+
+  call zgemm('N','N',ao_num,m,m,(1.d0,0.d0),mo_coef_new,size(mo_coef_new,1),U,size(U,1),(0.d0,0.d0),mo_coef_complex,size(mo_coef_complex,1))
+  deallocate(A,mo_coef_new,U,Vt,D)
+  call write_time(6)
+
+  mo_label = label
+end
+
+
+subroutine mo_as_svd_vectors_of_mo_matrix_eig_complex(matrix,lda,m,n,eig,label)
+  !TODO: test this
+  implicit none
+  integer,intent(in)             :: lda,m,n
+  character*(64), intent(in)     :: label
+  complex*16, intent(in)   :: matrix(lda,n)
+  double precision, intent(out)  :: eig(m)
+
+  integer :: i,j
+  double precision :: accu
+  double precision, allocatable  :: D(:)
+  complex*16, allocatable  :: mo_coef_new(:,:), U(:,:), A(:,:), Vt(:,:), work(:)
+  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: mo_coef_new, U, Vt, A
+
+  call write_time(6)
+  if (m /= mo_num) then
+    print *, irp_here, ': Error : m/= mo_num'
+    stop 1
+  endif
+
+  allocate(A(lda,n),U(lda,n),mo_coef_new(ao_num,m),D(m),Vt(lda,n))
+
+  do j=1,n
+    do i=1,m
+      A(i,j) = matrix(i,j)
+    enddo
+  enddo
+  mo_coef_new = mo_coef_complex
+
+  call svd_complex(A,lda,U,lda,D,Vt,lda,m,n)
+
+  write (6,'(A)') 'MOs are now **'//trim(label)//'**'
+  write (6,'(A)')  ''
+  write (6,'(A)') 'Eigenvalues'
+  write (6,'(A)')  '-----------'
+  write (6,'(A)') ''
+  write (6,'(A)')  '======== ================ ================'
+  write (6,'(A)')  '   MO       Eigenvalue       Cumulative   '
+  write (6,'(A)')  '======== ================ ================'
+
+  accu = 0.d0
+  do i=1,m
+    accu = accu + D(i)
+    write (6,'(I8,1X,F16.10,1X,F16.10)')  i,D(i), accu
+  enddo
+  write (6,'(A)')  '======== ================ ================'
+  write (6,'(A)')  ''
+
+  call zgemm('N','N',ao_num,m,m,(1.d0,0.d0),mo_coef_new,size(mo_coef_new,1),U,size(U,1),(0.d0,0.d0),mo_coef_complex,size(mo_coef_complex,1))
+
+  do i=1,m
+    eig(i) = D(i)
+  enddo
+
+  deallocate(A,mo_coef_new,U,Vt,D)
+  call write_time(6)
+
+  mo_label = label
+
+end
+
+
+subroutine mo_coef_new_as_svd_vectors_of_mo_matrix_eig_complex(matrix,lda,m,n,mo_coef_before,eig,mo_coef_new)
+  implicit none
+  BEGIN_DOC
+! You enter with matrix in the MO basis defined with the mo_coef_before. 
+!
+! You SVD the matrix and set the eigenvectors as mo_coef_new ordered by increasing singular values 
+  END_DOC
+  integer,intent(in)             :: lda,m,n
+  complex*16, intent(in)   :: matrix(lda,n),mo_coef_before(ao_num,m)
+  double precision, intent(out)  :: eig(m)
+  complex*16, intent(out)  :: mo_coef_new(ao_num,m)
+
+  integer :: i,j
+  double precision :: accu
+  double precision, allocatable  ::  D(:)
+  complex*16, allocatable  ::  mo_coef_tmp(:,:), U(:,:), A(:,:), Vt(:,:), work(:)
+  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, Vt, A
+
+  call write_time(6)
+  if (m /= mo_num) then
+    print *, irp_here, ': Error : m/= mo_num'
+    stop 1
+  endif
+
+  allocate(A(lda,n),U(lda,n),D(m),Vt(lda,n),mo_coef_tmp(ao_num,mo_num))
+
+  do j=1,n
+    do i=1,m
+      A(i,j) = matrix(i,j)
+    enddo
+  enddo
+  mo_coef_tmp = mo_coef_before
+
+  call svd_complex(A,lda,U,lda,D,Vt,lda,m,n)
+
+  write (6,'(A)')  ''
+  write (6,'(A)') 'Eigenvalues'
+  write (6,'(A)')  '-----------'
+  write (6,'(A)') ''
+  write (6,'(A)')  '======== ================ ================'
+  write (6,'(A)')  '   MO       Eigenvalue       Cumulative   '
+  write (6,'(A)')  '======== ================ ================'
+
+  accu = 0.d0
+  do i=1,m
+    accu = accu + D(i)
+    write (6,'(I8,1X,F16.10,1X,F16.10)')  i,D(i), accu
+  enddo
+  write (6,'(A)')  '======== ================ ================'
+  write (6,'(A)')  ''
+
+  call zgemm('N','N',ao_num,m,m,(1.d0,0.d0),mo_coef_tmp,size(mo_coef_new,1),U,size(U,1),(0.d0,0.d0),mo_coef_new,size(mo_coef_new,1))
+
+  do i=1,m
+    eig(i) = D(i)
+  enddo
+
+  deallocate(A,U,Vt,D,mo_coef_tmp)
+  call write_time(6)
+
+end
+
+!============================================!
+!                                            !
+!                    kpts                    !
+!                                            !
+!============================================!
+
+subroutine mo_as_eigvectors_of_mo_matrix_kpts(matrix,n,m,nk,label,sign,output)
+  !TODO: test this
+  implicit none
+  integer,intent(in)             :: n,m,nk, sign
+  character*(64), intent(in)     :: label
+  complex*16, intent(in)   :: matrix(n,m,nk)
+  logical, intent(in)            :: output
+
+  integer :: i,j,k
+  double precision, allocatable  :: eigvalues(:)
+  complex*16, allocatable  :: mo_coef_new(:,:), R(:,:), A(:,:)
+  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: mo_coef_new, R
+
+  call write_time(6)
+  if (m /= mo_num_per_kpt) then
+    print *, irp_here, ': Error : m/= mo_num_per_kpt'
+    stop 1
+  endif
+  if (nk /= kpt_num) then
+    print *, irp_here, ': Error : nk/= kpt_num'
+    stop 1
+  endif
+  allocate(A(n,m),R(n,m),mo_coef_new(ao_num_per_kpt,m),eigvalues(m))
+  do k=1,nk
+    if (sign == -1) then
+      do j=1,m
+        do i=1,n
+          A(i,j) = -matrix(i,j,k)
+        enddo
+      enddo
+    else
+      do j=1,m
+        do i=1,n
+          A(i,j) = matrix(i,j,k)
+        enddo
+      enddo
+    endif
+    mo_coef_new = mo_coef_kpts(:,:,k)
+
+    call lapack_diag_complex(eigvalues,R,A,n,m)
+    if (sign == -1) then
+      do i=1,m
+        eigvalues(i) = -eigvalues(i)
+      enddo
+    endif
+    if (output) then
+      do i=1,m
+        write (6,'(2(I8),1X,F16.10)') k,i,eigvalues(i)
+      enddo
+      write (6,'(A)') '======== ================'
+      write (6,'(A)')  ''
+      !write (6,'(A)')  'Fock Matrix'
+      !write (6,'(A)') '-----------'
+      !do i=1,n
+      !  write(*,'(200(E24.15))') A(i,:)
+      !enddo
+    endif
+
+    call zgemm('N','N',ao_num_per_kpt,m,m,(1.d0,0.d0), &
+        mo_coef_new,size(mo_coef_new,1),R,size(R,1),(0.d0,0.d0), &
+        mo_coef_kpts(:,:,k),size(mo_coef_kpts,1))
+  enddo
+  deallocate(A,mo_coef_new,R,eigvalues)
+  call write_time(6)
+
+  mo_label = label
+    if (output) then
+      write (6,'(A)')  'MOs are now **'//trim(label)//'**'
+      write (6,'(A)') ''
+      write (6,'(A)')  'Eigenvalues'
+      write (6,'(A)') '-----------'
+      write (6,'(A)')  ''
+      write (6,'(A)') '======== ================'
+    endif
+end
+
+subroutine mo_as_svd_vectors_of_mo_matrix_kpts(matrix,lda,m,n,label)
+  !TODO: implement
+  print *, irp_here, ' not implemented for kpts'
+  stop 1
+  implicit none
+  integer,intent(in)             :: lda,m,n
+  character*(64), intent(in)     :: label
+  complex*16, intent(in)   :: matrix(lda,n)
+
+  integer :: i,j
+  double precision :: accu
+  double precision, allocatable  :: D(:)
+  complex*16, allocatable  :: mo_coef_new(:,:), U(:,:), A(:,:), Vt(:,:)
+  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: mo_coef_new, U, Vt, A
+
+  call write_time(6)
+  if (m /= mo_num) then
+    print *, irp_here, ': Error : m/= mo_num'
+    stop 1
+  endif
+
+  allocate(A(lda,n),U(lda,n),mo_coef_new(ao_num,m),D(m),Vt(lda,n))
+
+  do j=1,n
+    do i=1,m
+      A(i,j) = matrix(i,j)
+    enddo
+  enddo
+  mo_coef_new = mo_coef_complex
+
+  call svd_complex(A,lda,U,lda,D,Vt,lda,m,n)
+
+  write (6,'(A)') 'MOs are now **'//trim(label)//'**'
+  write (6,'(A)')  ''
+  write (6,'(A)') 'Eigenvalues'
+  write (6,'(A)')  '-----------'
+  write (6,'(A)') ''
+  write (6,'(A)')  '======== ================ ================'
+  write (6,'(A)')  '   MO       Eigenvalue       Cumulative   '
+  write (6,'(A)')  '======== ================ ================'
+
+  accu = 0.d0
+  do i=1,m
+    accu = accu + D(i)
+    write (6,'(I8,1X,F16.10,1X,F16.10)')  i,D(i), accu
+  enddo
+  write (6,'(A)')  '======== ================ ================'
+  write (6,'(A)')  ''
+
+  call zgemm('N','N',ao_num,m,m,(1.d0,0.d0),mo_coef_new,size(mo_coef_new,1),U,size(U,1),(0.d0,0.d0),mo_coef_complex,size(mo_coef_complex,1))
+  deallocate(A,mo_coef_new,U,Vt,D)
+  call write_time(6)
+
+  mo_label = label
+end
+
+
+subroutine mo_as_svd_vectors_of_mo_matrix_eig_kpts(matrix,lda,m,n,nk,eig,label)
+  !TODO: implement
+  !print *, irp_here, ' not implemented for kpts'
+  !stop 1
+  implicit none
+  integer,intent(in)             :: lda,m,n,nk
+  character*(64), intent(in)     :: label
+  complex*16, intent(in)   :: matrix(lda,n,nk)
+  double precision, intent(out)  :: eig(m,nk)
+
+  integer :: i,j,k
+  double precision :: accu
+  double precision, allocatable  :: D(:)
+  complex*16, allocatable  :: mo_coef_new(:,:), U(:,:), A(:,:), Vt(:,:), work(:)
+  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: mo_coef_new, U, Vt, A
+
+  call write_time(6)
+  if (m /= mo_num_per_kpt) then
+    print *, irp_here, ': Error : m/= mo_num_per_kpt'
+    stop 1
+  endif
+
+  
+  allocate(A(lda,n),U(lda,n),mo_coef_new(ao_num_per_kpt,m),D(m),Vt(lda,n))
+
+  do k=1,nk
+    do j=1,n
+      do i=1,m
+        A(i,j) = matrix(i,j,k)
+      enddo
+    enddo
+    mo_coef_new(1:ao_num_per_kpt,1:m) = mo_coef_kpts(1:ao_num_per_kpt,1:m,k)
+
+    call svd_complex(A,lda,U,lda,D,Vt,lda,m,n)
+
+
+
+    call zgemm('N','N',ao_num_per_kpt,m,m,  &
+               (1.d0,0.d0),mo_coef_new,size(mo_coef_new,1),U,size(U,1),&
+               (0.d0,0.d0),mo_coef_kpts(1,1,k),size(mo_coef_kpts,1))
+
+    do i=1,m
+      eig(i,k) = D(i)
+    enddo
+    !do j=1,mo_num_per_kpt
+    !  do i=1,mo_num_per_kpt
+    !    print'(3(I5),2(E25.15))',i,j,k,mo_coef_kpts(i,j,k)
+    !  enddo
+    !enddo
+  enddo
+
+  deallocate(A,mo_coef_new,U,Vt,D)
+
+  write (6,'(A)') 'MOs are now **'//trim(label)//'**'
+  write (6,'(A)')  ''
+  write (6,'(A)') 'Eigenvalues '
+  write (6,'(A)')  '-----------'
+  write (6,'(A)') ''
+  write (6,'(A)')  '======== ================ ================'
+  write (6,'(A)')  '   MO       Eigenvalue       Cumulative   '
+  write (6,'(A)')  '======== ================ ================'
+ 
+  do k=1,nk
+    accu = 0.d0
+    do i=1,m
+      accu = accu + eig(i,k)
+      write (6,'(I8,1X,F16.10,1X,F16.10)')  i,eig(i,k), accu
+    enddo
+  write (6,'(A)')  '-------- ---------------- ----------------'
+  enddo
+  write (6,'(A)')  '======== ================ ================'
+  write (6,'(A)')  ''
+
+  call write_time(6)
+
+  mo_label = label
+
+end
+
+
+subroutine mo_coef_new_as_svd_vectors_of_mo_matrix_eig_kpts(matrix,lda,m,n,mo_coef_before,eig,mo_coef_new)
+  !TODO: implement
+  print *, irp_here, ' not implemented for kpts'
+  stop 1
+  implicit none
+  BEGIN_DOC
+! You enter with matrix in the MO basis defined with the mo_coef_before. 
+!
+! You SVD the matrix and set the eigenvectors as mo_coef_new ordered by increasing singular values 
+  END_DOC
+  integer,intent(in)             :: lda,m,n
+  complex*16, intent(in)   :: matrix(lda,n),mo_coef_before(ao_num,m)
+  double precision, intent(out)  :: eig(m)
+  complex*16, intent(out)  :: mo_coef_new(ao_num,m)
+
+  integer :: i,j
+  double precision :: accu
+  double precision, allocatable  ::  D(:)
+  complex*16, allocatable  ::  mo_coef_tmp(:,:), U(:,:), A(:,:), Vt(:,:), work(:)
+  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: U, Vt, A
+
+  call write_time(6)
+  if (m /= mo_num) then
+    print *, irp_here, ': Error : m/= mo_num'
+    stop 1
+  endif
+
+  allocate(A(lda,n),U(lda,n),D(m),Vt(lda,n),mo_coef_tmp(ao_num,mo_num))
+
+  do j=1,n
+    do i=1,m
+      A(i,j) = matrix(i,j)
+    enddo
+  enddo
+  mo_coef_tmp = mo_coef_before
+
+  call svd_complex(A,lda,U,lda,D,Vt,lda,m,n)
+
+  write (6,'(A)')  ''
+  write (6,'(A)') 'Eigenvalues'
+  write (6,'(A)')  '-----------'
+  write (6,'(A)') ''
+  write (6,'(A)')  '======== ================ ================'
+  write (6,'(A)')  '   MO       Eigenvalue       Cumulative   '
+  write (6,'(A)')  '======== ================ ================'
+
+  accu = 0.d0
+  do i=1,m
+    accu = accu + D(i)
+    write (6,'(I8,1X,F16.10,1X,F16.10)')  i,D(i), accu
+  enddo
+  write (6,'(A)')  '======== ================ ================'
+  write (6,'(A)')  ''
+
+  call zgemm('N','N',ao_num,m,m,(1.d0,0.d0),mo_coef_tmp,size(mo_coef_new,1),U,size(U,1),(0.d0,0.d0),mo_coef_new,size(mo_coef_new,1))
+
+  do i=1,m
+    eig(i) = D(i)
+  enddo
+
+  deallocate(A,U,Vt,D,mo_coef_tmp)
+  call write_time(6)
+
+end
+

src/mo_guess/h_core_guess_routine.irp.f

@@ -5,9 +5,18 @@ subroutine hcore_guess
   implicit none
   character*(64)                 :: label
   label = "Guess"
-  call mo_as_eigvectors_of_mo_matrix(mo_one_e_integrals,          &
-                                     size(mo_one_e_integrals,1),  &
-                                     size(mo_one_e_integrals,2),label,1,.false.)
-  call save_mos
-  SOFT_TOUCH mo_coef mo_label
+  if (is_complex) then
+    call mo_as_eigvectors_of_mo_matrix_complex(mo_one_e_integrals_complex,  &
+                                       size(mo_one_e_integrals_complex,1),  &
+                                       size(mo_one_e_integrals_complex,2),label,1,.false.)
+    call save_mos
+    SOFT_TOUCH mo_coef_complex mo_label
+
+  else
+    call mo_as_eigvectors_of_mo_matrix(mo_one_e_integrals,          &
+                                       size(mo_one_e_integrals,1),  &
+                                       size(mo_one_e_integrals,2),label,1,.false.)
+    call save_mos
+    SOFT_TOUCH mo_coef mo_label
+  endif
 end

src/mo_guess/mo_ortho_lowdin_cplx.irp.f

@@ -0,0 +1,109 @@
+BEGIN_PROVIDER [complex*16, ao_ortho_lowdin_coef_complex, (ao_num,ao_num)]
+  implicit none
+  BEGIN_DOC
+! matrix of the coefficients of the mos generated by the
+! orthonormalization by the S^{-1/2} canonical transformation of the aos
+! ao_ortho_lowdin_coef(i,j) = coefficient of the ith ao on the jth ao_ortho_lowdin orbital
+  END_DOC
+  integer                        :: i,j,k,l
+  complex*16, allocatable  :: tmp_matrix(:,:)
+  allocate (tmp_matrix(ao_num,ao_num))
+  tmp_matrix(:,:) = (0.d0,0.d0)
+  do j=1, ao_num
+    tmp_matrix(j,j) = (1.d0,0.d0)
+  enddo
+  call ortho_lowdin_complex(ao_overlap_complex,ao_num,ao_num,tmp_matrix,ao_num,ao_num)
+  do i=1, ao_num
+    do j=1, ao_num
+      ao_ortho_lowdin_coef_complex(j,i) = tmp_matrix(i,j)
+    enddo
+  enddo
+  deallocate(tmp_matrix)
+END_PROVIDER
+
+BEGIN_PROVIDER [complex*16, ao_ortho_lowdin_overlap_complex, (ao_num,ao_num)]
+  implicit none
+  BEGIN_DOC
+! overlap matrix of the ao_ortho_lowdin
+! supposed to be the Identity
+  END_DOC
+  integer                        :: i,j,k,l
+  complex*16               :: c
+  do j=1, ao_num
+    do i=1, ao_num
+      ao_ortho_lowdin_overlap_complex(i,j) = (0.d0,0.d0)
+    enddo
+  enddo
+  do k=1, ao_num
+    do j=1, ao_num
+      c = (0.d0,0.d0)
+      do l=1, ao_num
+        c +=  dconjg(ao_ortho_lowdin_coef_complex(j,l)) * ao_overlap_complex(k,l)
+      enddo
+      do i=1, ao_num
+        ao_ortho_lowdin_overlap_complex(i,j) += ao_ortho_lowdin_coef_complex(i,k) * c
+      enddo
+    enddo
+  enddo
+END_PROVIDER
+
+!============================================!
+!                                            !
+!                    kpts                    !
+!                                            !
+!============================================!
+
+BEGIN_PROVIDER [complex*16, ao_ortho_lowdin_coef_kpts, (ao_num_per_kpt,ao_num_per_kpt,kpt_num)]
+  implicit none
+  BEGIN_DOC
+! matrix of the coefficients of the mos generated by the
+! orthonormalization by the S^{-1/2} canonical transformation of the aos
+! ao_ortho_lowdin_coef(i,j) = coefficient of the ith ao on the jth ao_ortho_lowdin orbital
+  END_DOC
+  integer                        :: i,j,k,l
+  complex*16, allocatable  :: tmp_matrix(:,:)
+  allocate (tmp_matrix(ao_num,ao_num))
+  do k=1,kpt_num
+    tmp_matrix(:,:) = (0.d0,0.d0)
+    do j=1, ao_num
+      tmp_matrix(j,j) = (1.d0,0.d0)
+    enddo
+    call ortho_lowdin_complex(ao_overlap_kpts(:,:,k),ao_num_per_kpt,ao_num_per_kpt,tmp_matrix,ao_num_per_kpt,ao_num_per_kpt)
+    do i=1, ao_num_per_kpt
+      do j=1, ao_num_per_kpt
+        ao_ortho_lowdin_coef_kpts(j,i,k) = tmp_matrix(i,j)
+      enddo
+    enddo
+  enddo
+  deallocate(tmp_matrix)
+END_PROVIDER
+
+BEGIN_PROVIDER [complex*16, ao_ortho_lowdin_overlap_kpts, (ao_num_per_kpt,ao_num_per_kpt,kpt_num)]
+  implicit none
+  BEGIN_DOC
+! overlap matrix of the ao_ortho_lowdin
+! supposed to be the Identity
+  END_DOC
+  integer                        :: i,j,k,l,kk
+  complex*16               :: c
+  do kk=1,kpt_num
+    do j=1, ao_num_per_kpt
+      do i=1, ao_num_per_kpt
+        ao_ortho_lowdin_overlap_kpts(i,j,kk) = (0.d0,0.d0)
+      enddo
+    enddo
+  enddo
+  do kk=1,kpt_num
+    do k=1, ao_num_per_kpt
+      do j=1, ao_num_per_kpt
+        c = (0.d0,0.d0)
+        do l=1, ao_num_per_kpt
+          c +=  dconjg(ao_ortho_lowdin_coef_kpts(j,l,kk)) * ao_overlap_kpts(k,l,kk)
+        enddo
+        do i=1, ao_num_per_kpt
+          ao_ortho_lowdin_overlap_kpts(i,j,kk) += ao_ortho_lowdin_coef_kpts(i,k,kk) * c
+        enddo
+      enddo
+    enddo
+  enddo
+END_PROVIDER

src/mo_guess/pot_mo_ortho_cano_ints.irp.f

@@ -0,0 +1,52 @@
+BEGIN_PROVIDER [double precision, ao_ortho_cano_n_e_ints, (mo_num,mo_num)]
+ implicit none
+ integer :: i1,j1,i,j
+ double precision :: c_i1,c_j1
+
+ ao_ortho_cano_n_e_ints = 0.d0
+ !$OMP PARALLEL DO DEFAULT(none) &
+ !$OMP PRIVATE(i,j,i1,j1,c_j1,c_i1) &
+ !$OMP SHARED(mo_num,ao_num,ao_ortho_canonical_coef, &
+ !$OMP   ao_ortho_cano_n_e_ints, ao_integrals_n_e)
+ do i = 1, mo_num
+   do j = 1, mo_num
+    do i1 = 1,ao_num
+     c_i1 = ao_ortho_canonical_coef(i1,i)
+     do j1 = 1,ao_num
+       c_j1 = c_i1*ao_ortho_canonical_coef(j1,j)
+       ao_ortho_cano_n_e_ints(j,i) = ao_ortho_cano_n_e_ints(j,i) + &
+                                           c_j1 * ao_integrals_n_e(j1,i1)
+     enddo
+    enddo
+   enddo
+ enddo
+ !$OMP END PARALLEL DO
+END_PROVIDER
+
+BEGIN_PROVIDER [complex*16, ao_ortho_cano_n_e_ints_cplx, (mo_num,mo_num)]
+!todo: kpts
+ implicit none
+ integer :: i1,j1,i,j
+ complex*16 :: c_i1,c_j1
+
+ ao_ortho_cano_n_e_ints_cplx = (0.d0,0.d0)
+ !$OMP PARALLEL DO DEFAULT(none) &
+ !$OMP PRIVATE(i,j,i1,j1,c_j1,c_i1) &
+ !$OMP SHARED(mo_num,ao_num,ao_ortho_canonical_coef_complex, &
+ !$OMP   ao_ortho_cano_n_e_ints_cplx, ao_integrals_n_e_complex)
+ do i = 1, mo_num
+   do j = 1, mo_num
+    do i1 = 1,ao_num
+     c_i1 = ao_ortho_canonical_coef_complex(i1,i)
+     do j1 = 1,ao_num
+       c_j1 = c_i1*dconjg(ao_ortho_canonical_coef_complex(j1,j))
+       ao_ortho_cano_n_e_ints_cplx(j,i) = &
+               ao_ortho_cano_n_e_ints_cplx(j,i) + &
+                c_j1 * ao_integrals_n_e_complex(j1,i1)
+     enddo
+    enddo
+   enddo
+ enddo
+ !$OMP END PARALLEL DO
+END_PROVIDER
+

src/mo_guess/pot_mo_ortho_canonical_ints.irp.f

@@ -1,25 +0,0 @@
-BEGIN_PROVIDER [double precision, ao_ortho_canonical_nucl_elec_integrals, (mo_num,mo_num)]
- implicit none
- integer :: i1,j1,i,j
- double precision :: c_i1,c_j1
-
- ao_ortho_canonical_nucl_elec_integrals = 0.d0
- !$OMP PARALLEL DO DEFAULT(none) &
- !$OMP PRIVATE(i,j,i1,j1,c_j1,c_i1) &
- !$OMP SHARED(mo_num,ao_num,ao_ortho_canonical_coef, &
- !$OMP   ao_ortho_canonical_nucl_elec_integrals, ao_integrals_n_e)
- do i = 1, mo_num
-   do j = 1, mo_num
-    do i1 = 1,ao_num
-     c_i1 = ao_ortho_canonical_coef(i1,i)
-     do j1 = 1,ao_num
-       c_j1 = c_i1*ao_ortho_canonical_coef(j1,j)
-       ao_ortho_canonical_nucl_elec_integrals(j,i) = ao_ortho_canonical_nucl_elec_integrals(j,i) + &
-                                           c_j1 * ao_integrals_n_e(j1,i1)
-     enddo
-    enddo
-   enddo
- enddo
- !$OMP END PARALLEL DO
-END_PROVIDER
-

src/mo_guess/pot_mo_ortho_lowdin_ints.irp.f

@@ -23,3 +23,29 @@ BEGIN_PROVIDER [double precision, ao_ortho_lowdin_nucl_elec_integrals, (mo_num,m
  !$OMP END PARALLEL DO
 END_PROVIDER
 
+BEGIN_PROVIDER [complex*16, ao_ortho_lowdin_n_e_ints_cplx, (mo_num,mo_num)]
+ implicit none
+ integer :: i1,j1,i,j
+ complex*16 :: c_i1,c_j1
+
+ ao_ortho_lowdin_nucl_elec_integrals = (0.d0,0.d0)
+ !$OMP PARALLEL DO DEFAULT(none) &
+ !$OMP PRIVATE(i,j,i1,j1,c_j1,c_i1) &
+ !$OMP SHARED(mo_num,ao_num,ao_ortho_lowdin_coef_complex, &
+ !$OMP   ao_ortho_lowdin_n_e_ints_cplx, ao_integrals_n_e_complex)
+ do i = 1, mo_num
+   do j = 1, mo_num
+    do i1 = 1,ao_num
+     c_i1 = ao_ortho_lowdin_coef_complex(i1,i)
+     do j1 = 1,ao_num
+       c_j1 = c_i1*dconjg(ao_ortho_lowdin_coef_complex(j1,j))
+       ao_ortho_lowdin_n_e_ints_cplx(j,i) = &
+         ao_ortho_lowdin_n_e_ints_cplx(j,i) + &
+                                    c_j1 * ao_integrals_n_e_complex(j1,i1)
+     enddo
+    enddo
+   enddo
+ enddo
+ !$OMP END PARALLEL DO
+END_PROVIDER
+

src/mo_one_e_ints/EZFIO.cfg

@@ -4,6 +4,18 @@ doc: Nucleus-electron integrals in |MO| basis set
 size: (mo_basis.mo_num,mo_basis.mo_num)
 interface: ezfio
 
+[mo_integrals_e_n_complex]
+type: double precision
+doc: Complex nucleus-electron integrals in |MO| basis set
+size: (2,mo_basis.mo_num,mo_basis.mo_num)
+interface: ezfio
+
+[mo_integrals_e_n_kpts]
+type: double precision
+doc: Complex nucleus-electron integrals in |MO| basis set
+size: (2,mo_basis.mo_num_per_kpt,mo_basis.mo_num_per_kpt,nuclei.kpt_num)
+interface: ezfio
+
 [io_mo_integrals_e_n]
 type: Disk_access
 doc: Read/Write |MO| electron-nucleus attraction integrals from/to disk [ Write | Read | None ]
@@ -17,12 +29,35 @@ doc: Kinetic energy integrals in |MO| basis set
 size: (mo_basis.mo_num,mo_basis.mo_num)
 interface: ezfio
 
+[mo_integrals_kinetic_complex]
+type: double precision
+doc: Complex kinetic energy integrals in |MO| basis set
+size: (2,mo_basis.mo_num,mo_basis.mo_num)
+interface: ezfio
+
+[mo_integrals_kinetic_kpts]
+type: double precision
+doc: Complex kinetic energy integrals in |MO| basis set
+size: (2,mo_basis.mo_num_per_kpt,mo_basis.mo_num_per_kpt,nuclei.kpt_num)
+interface: ezfio
+
 [io_mo_integrals_kinetic]
 type: Disk_access
 doc: Read/Write |MO| one-electron kinetic integrals from/to disk [ Write | Read | None ]
 interface: ezfio,provider,ocaml
 default: None
 
+[mo_integrals_overlap_kpts]
+type: double precision
+doc: Complex overlap integrals in |MO| basis set
+size: (2,mo_basis.mo_num_per_kpt,mo_basis.mo_num_per_kpt,nuclei.kpt_num)
+interface: ezfio
+
+[io_mo_integrals_overlap]
+type: Disk_access
+doc: Read/Write |MO| one-electron overlap integrals from/to disk [ Write | Read | None ]
+interface: ezfio,provider,ocaml
+default: None
 
 
 [mo_integrals_pseudo]
@@ -31,18 +66,43 @@ doc: Pseudopotential integrals in |MO| basis set
 size: (mo_basis.mo_num,mo_basis.mo_num)
 interface: ezfio
 
+[mo_integrals_pseudo_complex]
+type: double precision
+doc: Complex pseudopotential integrals in |MO| basis set
+size: (2,mo_basis.mo_num,mo_basis.mo_num)
+interface: ezfio
+
+[mo_integrals_pseudo_kpts]
+type: double precision
+doc: Complex pseudopotential integrals in |MO| basis set
+size: (2,mo_basis.mo_num_per_kpt,mo_basis.mo_num_per_kpt,nuclei.kpt_num)
+interface: ezfio
+
 [io_mo_integrals_pseudo]
 type: Disk_access
 doc: Read/Write |MO| pseudopotential integrals from/to disk [ Write | Read | None ]
 interface: ezfio,provider,ocaml
 default: None
 
+
 [mo_one_e_integrals]
 type: double precision
 doc: One-electron integrals in |MO| basis set
 size: (mo_basis.mo_num,mo_basis.mo_num)
 interface: ezfio
 
+[mo_one_e_integrals_complex]
+type: double precision
+doc: Complex one-electron integrals in |MO| basis set
+size: (2,mo_basis.mo_num,mo_basis.mo_num)
+interface: ezfio
+
+[mo_one_e_integrals_kpts]
+type: double precision
+doc: Complex one-electron integrals in |MO| basis set
+size: (2,mo_basis.mo_num_per_kpt,mo_basis.mo_num_per_kpt,nuclei.kpt_num)
+interface: ezfio
+
 [io_mo_one_e_integrals]
 type: Disk_access
 doc: Read/Write |MO| one-electron integrals from/to disk [ Write | Read | None ]

src/mo_one_e_ints/ao_to_mo.irp.f

@@ -63,4 +63,3 @@ BEGIN_PROVIDER [ double precision, S_mo_coef, (ao_num, mo_num) ]
 
 END_PROVIDER
 
-

src/mo_one_e_ints/ao_to_mo_cplx.irp.f

@@ -0,0 +1,146 @@
+subroutine mo_to_ao_complex(A_mo,LDA_mo,A_ao,LDA_ao)
+  implicit none
+  BEGIN_DOC
+  ! Transform A from the MO basis to the AO basis
+  !
+  ! (S.C).A_mo.(S.C)t
+  END_DOC
+  integer, intent(in)            :: LDA_ao,LDA_mo
+  complex*16, intent(in)         :: A_mo(LDA_mo,mo_num)
+  complex*16, intent(out)        :: A_ao(LDA_ao,ao_num)
+  complex*16, allocatable        :: T(:,:)
+  
+  allocate ( T(mo_num,ao_num) )
+  
+  call zgemm('N','C', mo_num, ao_num, mo_num,                &
+      (1.d0,0.d0), A_mo,size(A_mo,1),                                &
+      S_mo_coef_complex, size(S_mo_coef_complex,1),                                  &
+      (0.d0,0.d0), T, size(T,1))
+  
+  call zgemm('N','N', ao_num, ao_num, mo_num,                    &
+      (1.d0,0.d0), S_mo_coef_complex, size(S_mo_coef_complex,1),                     &
+      T, size(T,1),                                                  &
+      (0.d0,0.d0), A_ao, size(A_ao,1))
+  
+  deallocate(T)
+end
+
+subroutine mo_to_ao_no_overlap_complex(A_mo,LDA_mo,A_ao,LDA_ao)
+  implicit none
+  BEGIN_DOC
+  ! Transform A from the MO basis to the S^-1 AO basis
+  ! Useful for density matrix
+  END_DOC
+  integer, intent(in)            :: LDA_ao,LDA_mo
+  complex*16, intent(in)         :: A_mo(LDA_mo,mo_num)
+  complex*16, intent(out)        :: A_ao(LDA_ao,ao_num)
+  complex*16, allocatable        :: T(:,:)
+  
+  allocate ( T(mo_num,ao_num) )
+  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
+  
+  call zgemm('N','C', mo_num, ao_num, mo_num,                &
+      (1.d0,0.d0), A_mo,size(A_mo,1),                                &
+      mo_coef_complex, size(mo_coef_complex,1),                                      &
+      (0.d0,0.d0), T, size(T,1))
+  
+  call zgemm('N','N', ao_num, ao_num, mo_num,                    &
+      (1.d0,0.d0), mo_coef_complex,size(mo_coef_complex,1),                          &
+      T, size(T,1),                                                  &
+      (0.d0,0.d0), A_ao, size(A_ao,1))
+  
+  deallocate(T)
+end
+
+BEGIN_PROVIDER [ complex*16, S_mo_coef_complex, (ao_num, mo_num) ]
+  implicit none
+  BEGIN_DOC
+  ! Product S.C where S is the overlap matrix in the AO basis and C the mo_coef matrix.
+  END_DOC
+
+  call zgemm('N','N',ao_num, mo_num, ao_num, (1.d0,0.d0), &
+        ao_overlap_complex, size(ao_overlap_complex,1), &
+        mo_coef_complex, size(mo_coef_complex,1), &
+        (0.d0,0.d0), &
+        S_mo_coef_complex, size(S_mo_coef_complex,1))
+
+END_PROVIDER
+
+!============================================!
+!                                            !
+!                    kpts                    !
+!                                            !
+!============================================!
+
+subroutine mo_to_ao_kpts(A_mo,LDA_mo,A_ao,LDA_ao)
+  implicit none
+  BEGIN_DOC
+  ! Transform A from the MO basis to the AO basis
+  !
+  ! (S.C).A_mo.(S.C)t
+  END_DOC
+  integer, intent(in)            :: LDA_ao,LDA_mo
+  complex*16, intent(in)         :: A_mo(LDA_mo,mo_num_per_kpt,kpt_num)
+  complex*16, intent(out)        :: A_ao(LDA_ao,ao_num_per_kpt,kpt_num)
+  complex*16, allocatable        :: T(:,:)
+  
+  allocate ( T(mo_num_per_kpt,ao_num_per_kpt) )
+  integer :: k
+  do k=1,kpt_num
+    call zgemm('N','C', mo_num_per_kpt, ao_num_per_kpt, mo_num_per_kpt,                &
+        (1.d0,0.d0), A_mo(:,:,k),size(A_mo,1),                                &
+        S_mo_coef_kpts(:,:,k), size(S_mo_coef_kpts,1),                                  &
+        (0.d0,0.d0), T, size(T,1))
+    
+    call zgemm('N','N', ao_num_per_kpt, ao_num_per_kpt, mo_num_per_kpt,                    &
+        (1.d0,0.d0), S_mo_coef_kpts(:,:,k), size(S_mo_coef_kpts,1),                     &
+        T, size(T,1),                                                  &
+        (0.d0,0.d0), A_ao(:,:,k), size(A_ao,1))
+  enddo
+  deallocate(T)
+end
+
+subroutine mo_to_ao_no_overlap_kpts(A_mo,LDA_mo,A_ao,LDA_ao)
+  implicit none
+  BEGIN_DOC
+  ! Transform A from the MO basis to the S^-1 AO basis
+  ! Useful for density matrix
+  END_DOC
+  integer, intent(in)            :: LDA_ao,LDA_mo
+  complex*16, intent(in)         :: A_mo(LDA_mo,mo_num_per_kpt,kpt_num)
+  complex*16, intent(out)        :: A_ao(LDA_ao,ao_num_per_kpt,kpt_num)
+  complex*16, allocatable        :: T(:,:)
+  
+  allocate ( T(mo_num_per_kpt,ao_num_per_kpt) )
+  !DIR$ ATTRIBUTES ALIGN : $IRP_ALIGN :: T
+  integer :: k
+  do k=1,kpt_num
+    call zgemm('N','C', mo_num_per_kpt, ao_num_per_kpt, mo_num_per_kpt,                &
+        (1.d0,0.d0), A_mo(:,:,k),size(A_mo,1),                                &
+        mo_coef_kpts(:,:,k), size(mo_coef_kpts,1),                                      &
+        (0.d0,0.d0), T, size(T,1))
+    
+    call zgemm('N','N', ao_num_per_kpt, ao_num_per_kpt, mo_num_per_kpt,                    &
+        (1.d0,0.d0), mo_coef_kpts(:,:,k),size(mo_coef_kpts,1),                          &
+        T, size(T,1),                                                  &
+        (0.d0,0.d0), A_ao(:,:,k), size(A_ao,1))
+  enddo
+  deallocate(T)
+end
+
+BEGIN_PROVIDER [ complex*16, S_mo_coef_kpts, (ao_num_per_kpt, mo_num_per_kpt, kpt_num) ]
+  implicit none
+  BEGIN_DOC
+  ! Product S.C where S is the overlap matrix in the AO basis and C the mo_coef matrix.
+  END_DOC
+
+  integer :: k
+  do k=1,kpt_num
+    call zgemm('N','N',ao_num_per_kpt, mo_num_per_kpt, ao_num_per_kpt, (1.d0,0.d0), &
+          ao_overlap_kpts(:,:,k), size(ao_overlap_kpts,1), &
+          mo_coef_kpts(:,:,k), size(mo_coef_kpts,1), &
+          (0.d0,0.d0), &
+          S_mo_coef_kpts(:,:,k), size(S_mo_coef_kpts,1))
+  enddo
+END_PROVIDER
+

src/mo_one_e_ints/kin_mo_ints.irp.f

@@ -22,3 +22,26 @@ BEGIN_PROVIDER [double precision, mo_kinetic_integrals, (mo_num,mo_num)]
 
 END_PROVIDER
 
+BEGIN_PROVIDER [ double precision, mo_kinetic_integrals_diag,(mo_num)]
+  implicit none
+  integer                        :: i
+  BEGIN_DOC
+  ! diagonal elements of mo_kinetic_integrals or mo_kinetic_integrals_complex
+  END_DOC
+  
+  if (is_complex) then
+    integer :: k,i_shft
+    PROVIDE mo_kinetic_integrals_kpts
+    do k=1,kpt_num
+      i_shft = (k-1)*mo_num_per_kpt
+      do i=1,mo_num_per_kpt
+        mo_kinetic_integrals_diag(i+i_shft) = dble(mo_kinetic_integrals_kpts(i,i,k))
+      enddo
+    enddo
+  else
+    PROVIDE mo_kinetic_integrals
+    do i=1,mo_num
+      mo_kinetic_integrals_diag(i) = mo_kinetic_integrals(i,i)
+    enddo
+  endif
+END_PROVIDER

src/mo_one_e_ints/kin_mo_ints_cplx.irp.f

@@ -0,0 +1,60 @@
+BEGIN_PROVIDER [complex*16, mo_kinetic_integrals_complex, (mo_num,mo_num)]
+  implicit none
+  BEGIN_DOC
+  !  Kinetic energy integrals in the MO basis
+  END_DOC
+  integer :: i,j
+
+  print *, 'Providing MO kinetic integrals'
+  if (read_mo_integrals_kinetic) then
+    call ezfio_get_mo_one_e_ints_mo_integrals_kinetic_complex(mo_kinetic_integrals_complex)
+    print *,  'MO kinetic integrals read from disk'
+  else
+  print *, 'Providing MO kinetic integrals from AO kinetic integrals'
+    call ao_to_mo_complex(                                            &
+        ao_kinetic_integrals_complex,                                 &
+        size(ao_kinetic_integrals_complex,1),                         &
+        mo_kinetic_integrals_complex,                                 &
+        size(mo_kinetic_integrals_complex,1)                          &
+        )
+  endif
+  if (write_mo_integrals_kinetic) then
+    call ezfio_set_mo_one_e_ints_mo_integrals_kinetic_complex(mo_kinetic_integrals_complex)
+    print *,  'MO kinetic integrals written to disk'
+  endif
+
+END_PROVIDER
+
+!============================================!
+!                                            !
+!                    kpts                    !
+!                                            !
+!============================================!
+
+BEGIN_PROVIDER [complex*16, mo_kinetic_integrals_kpts, (mo_num_per_kpt,mo_num_per_kpt,kpt_num)]
+  implicit none
+  BEGIN_DOC
+  !  Kinetic energy integrals in the MO basis
+  END_DOC
+  integer :: i,j
+
+  print *, 'Providing MO kinetic integrals'
+  if (read_mo_integrals_kinetic) then
+    call ezfio_get_mo_one_e_ints_mo_integrals_kinetic_kpts(mo_kinetic_integrals_kpts)
+    print *,  'MO kinetic integrals read from disk'
+  else
+  print *, 'Providing MO kinetic integrals from AO kinetic integrals'
+    call ao_to_mo_kpts(                                            &
+        ao_kinetic_integrals_kpts,                                 &
+        size(ao_kinetic_integrals_kpts,1),                         &
+        mo_kinetic_integrals_kpts,                                 &
+        size(mo_kinetic_integrals_kpts,1)                          &
+        )
+  endif
+  if (write_mo_integrals_kinetic) then
+    call ezfio_set_mo_one_e_ints_mo_integrals_kinetic_kpts(mo_kinetic_integrals_kpts)
+    print *,  'MO kinetic integrals written to disk'
+  endif
+
+END_PROVIDER
+

src/mo_one_e_ints/mo_one_e_ints.irp.f

@@ -24,3 +24,27 @@ BEGIN_PROVIDER [ double precision, mo_one_e_integrals,(mo_num,mo_num)]
   ENDIF
 
 END_PROVIDER
+
+BEGIN_PROVIDER [ double precision, mo_one_e_integrals_diag,(mo_num)]
+  implicit none
+  integer                        :: i
+  BEGIN_DOC
+  ! diagonal elements of mo_one_e_integrals or mo_one_e_integrals_complex
+  END_DOC
+  
+  if (is_complex) then
+    integer :: k,i_shft
+    PROVIDE mo_one_e_integrals_kpts
+    do k=1,kpt_num
+      i_shft = (k-1)*mo_num_per_kpt
+      do i=1,mo_num_per_kpt
+        mo_one_e_integrals_diag(i+i_shft) = dble(mo_one_e_integrals_kpts(i,i,k))
+      enddo
+    enddo
+  else
+    PROVIDE mo_one_e_integrals
+    do i=1,mo_num
+      mo_one_e_integrals_diag(i) = mo_one_e_integrals(i,i)
+    enddo
+  endif
+END_PROVIDER

src/mo_one_e_ints/mo_one_e_ints_cplx.irp.f

@@ -0,0 +1,61 @@
+BEGIN_PROVIDER [ complex*16, mo_one_e_integrals_complex,(mo_num,mo_num)]
+  implicit none
+  integer                        :: i,j,n,l
+  BEGIN_DOC
+  ! array of the one-electron Hamiltonian on the |MO| basis :
+  ! sum of the kinetic and nuclear electronic potentials (and pseudo potential if needed)
+  END_DOC
+  print*,'Providing the one-electron integrals'
+
+  IF (read_mo_one_e_integrals) THEN
+    call ezfio_get_mo_one_e_ints_mo_one_e_integrals_complex(mo_one_e_integrals_complex)
+  ELSE
+    mo_one_e_integrals_complex  = mo_integrals_n_e_complex + mo_kinetic_integrals_complex
+
+    IF (do_pseudo) THEN
+      mo_one_e_integrals_complex  += mo_pseudo_integrals_complex
+    ENDIF
+
+  ENDIF
+
+  IF (write_mo_one_e_integrals) THEN
+    call ezfio_set_mo_one_e_ints_mo_one_e_integrals_complex(mo_one_e_integrals_complex)
+    print *,  'MO one-e integrals written to disk'
+  ENDIF
+  print*,'Provided the one-electron integrals'
+
+END_PROVIDER
+
+!============================================!
+!                                            !
+!                    kpts                    !
+!                                            !
+!============================================!
+
+BEGIN_PROVIDER [ complex*16, mo_one_e_integrals_kpts,(mo_num_per_kpt,mo_num_per_kpt,kpt_num)]
+  implicit none
+  integer                        :: i,j,n,l
+  BEGIN_DOC
+  ! array of the one-electron Hamiltonian on the |MO| basis :
+  ! sum of the kinetic and nuclear electronic potentials (and pseudo potential if needed)
+  END_DOC
+  print*,'Providing the one-electron integrals'
+
+  IF (read_mo_one_e_integrals) THEN
+    call ezfio_get_mo_one_e_ints_mo_one_e_integrals_kpts(mo_one_e_integrals_kpts)
+  ELSE
+    mo_one_e_integrals_kpts  = mo_integrals_n_e_kpts + mo_kinetic_integrals_kpts
+
+    IF (do_pseudo) THEN
+      mo_one_e_integrals_kpts  += mo_pseudo_integrals_kpts
+    ENDIF
+
+  ENDIF
+
+  IF (write_mo_one_e_integrals) THEN
+    call ezfio_set_mo_one_e_ints_mo_one_e_integrals_kpts(mo_one_e_integrals_kpts)
+    print *,  'MO one-e integrals written to disk'
+  ENDIF
+  print*,'Provided the one-electron integrals'
+
+END_PROVIDER

src/mo_one_e_ints/mo_overlap.irp.f

@@ -37,3 +37,94 @@ BEGIN_PROVIDER [ double precision, mo_overlap,(mo_num,mo_num) ]
 
 END_PROVIDER
 
+BEGIN_PROVIDER [ complex*16, mo_overlap_complex,(mo_num,mo_num) ]
+  implicit none
+  BEGIN_DOC
+! Provider to check that the MOs are indeed orthonormal.
+  END_DOC
+  integer :: i,j,n,l
+  integer :: lmax
+
+
+  lmax = (ao_num/4) * 4
+  !$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(NONE) &
+  !$OMP  PRIVATE(i,j,n,l) &
+  !$OMP  SHARED(mo_overlap_complex,mo_coef_complex,ao_overlap_complex, &
+  !$OMP    mo_num,ao_num,lmax)
+  do j=1,mo_num
+   do i= 1,mo_num
+    mo_overlap_complex(i,j) = (0.d0,0.d0)
+    do n = 1, lmax,4
+     do l = 1, ao_num
+      mo_overlap_complex(i,j) = mo_overlap_complex(i,j) + dconjg(mo_coef_complex(l,i)) * &
+           ( mo_coef_complex(n  ,j) * ao_overlap_complex(l,n  )  &
+           + mo_coef_complex(n+1,j) * ao_overlap_complex(l,n+1)  &
+           + mo_coef_complex(n+2,j) * ao_overlap_complex(l,n+2)  &
+           + mo_coef_complex(n+3,j) * ao_overlap_complex(l,n+3)  )
+     enddo
+    enddo
+    do n = lmax+1, ao_num
+     do l = 1, ao_num
+      mo_overlap_complex(i,j) = mo_overlap_complex(i,j) + mo_coef_complex(n,j) * dconjg(mo_coef_complex(l,i)) * ao_overlap_complex(l,n)
+     enddo
+    enddo
+   enddo
+  enddo
+  !$OMP END PARALLEL DO
+
+END_PROVIDER
+
+BEGIN_PROVIDER [ complex*16, mo_overlap_kpts,(mo_num_per_kpt,mo_num_per_kpt,kpt_num) ]
+  implicit none
+  BEGIN_DOC
+! Provider to check that the MOs are indeed orthonormal.
+  END_DOC
+  integer :: i,j,n,l,k
+  integer :: lmax
+
+  print *, 'Providing MO overlap integrals'
+  if (read_mo_integrals_overlap) then
+    call ezfio_get_mo_one_e_ints_mo_integrals_overlap_kpts(mo_overlap_kpts)
+    print *,  'MO overlap integrals read from disk'
+  else
+  print *, 'Providing MO overlap integrals from AO overlap integrals'
+  !  call ao_to_mo_kpts(                                            &
+  !      ao_kinetic_integrals_kpts,                                 &
+  !      size(ao_kinetic_integrals_kpts,1),                         &
+  !      mo_kinetic_integrals_kpts,                                 &
+  !      size(mo_kinetic_integrals_kpts,1)                          &
+  !      )
+  !endif
+  
+
+  lmax = (ao_num_per_kpt/4) * 4
+  !$OMP PARALLEL DO SCHEDULE(STATIC) DEFAULT(NONE) &
+  !$OMP  PRIVATE(i,j,n,l,k) &
+  !$OMP  SHARED(mo_overlap_kpts,mo_coef_kpts,ao_overlap_kpts, &
+  !$OMP    mo_num_per_kpt,ao_num_per_kpt,lmax,kpt_num)
+  do k=1,kpt_num
+    do j=1,mo_num_per_kpt
+      do i= 1,mo_num_per_kpt
+        mo_overlap_kpts(i,j,k) = (0.d0,0.d0)
+        do n = 1, lmax,4
+          do l = 1, ao_num_per_kpt
+            mo_overlap_kpts(i,j,k) = mo_overlap_kpts(i,j,k) + dconjg(mo_coef_kpts(l,i,k)) * &
+                 ( mo_coef_kpts(n  ,j,k) * ao_overlap_kpts(l,n  ,k)  &
+                 + mo_coef_kpts(n+1,j,k) * ao_overlap_kpts(l,n+1,k)  &
+                 + mo_coef_kpts(n+2,j,k) * ao_overlap_kpts(l,n+2,k)  &
+                 + mo_coef_kpts(n+3,j,k) * ao_overlap_kpts(l,n+3,k)  )
+          enddo
+        enddo
+        do n = lmax+1, ao_num_per_kpt
+          do l = 1, ao_num_per_kpt
+            mo_overlap_kpts(i,j,k) = mo_overlap_kpts(i,j,k) + mo_coef_kpts(n,j,k) * &
+              dconjg(mo_coef_kpts(l,i,k)) * ao_overlap_kpts(l,n,k)
+          enddo
+        enddo
+      enddo
+    enddo
+  enddo
+  !$OMP END PARALLEL DO
+  endif
+END_PROVIDER
+

src/mo_one_e_ints/orthonormalize.irp.f

@@ -1,11 +1,21 @@
 subroutine orthonormalize_mos
   implicit none
-  integer :: m,p,s
-  m = size(mo_coef,1)
-  p = size(mo_overlap,1)
-  call ortho_lowdin(mo_overlap,p,mo_num,mo_coef,m,ao_num)
-  mo_label = 'Orthonormalized'
-  SOFT_TOUCH mo_coef mo_label
+  integer :: m,p,s,k
+  if (is_complex) then
+    do k=1,kpt_num
+      m = size(mo_coef_kpts,1)
+      p = size(mo_overlap_kpts,1)
+      call ortho_lowdin_complex(mo_overlap_kpts(1,1,k),p,mo_num_per_kpt,mo_coef_kpts(1,1,k),m,ao_num_per_kpt)
+    enddo
+    mo_label = 'Orthonormalized'
+    SOFT_TOUCH mo_coef_kpts mo_label
+  else
+    m = size(mo_coef,1)
+    p = size(mo_overlap,1)
+    call ortho_lowdin(mo_overlap,p,mo_num,mo_coef,m,ao_num)
+    mo_label = 'Orthonormalized'
+    SOFT_TOUCH mo_coef mo_label
+  endif
 end
 
 

src/mo_one_e_ints/pot_mo_ints.irp.f

@@ -44,3 +44,26 @@ BEGIN_PROVIDER [double precision, mo_integrals_n_e_per_atom, (mo_num,mo_num,nucl
 
 END_PROVIDER
 
+BEGIN_PROVIDER [ double precision, mo_integrals_n_e_diag,(mo_num)]
+  implicit none
+  integer                        :: i
+  BEGIN_DOC
+  ! diagonal elements of mo_integrals_n_e or mo_integrals_n_e_complex
+  END_DOC
+  
+  if (is_complex) then
+    integer :: k,i_shft
+    PROVIDE mo_integrals_n_e_kpts
+    do k=1,kpt_num
+      i_shft = (k-1)*mo_num_per_kpt
+      do i=1,mo_num_per_kpt
+        mo_integrals_n_e_diag(i+i_shft) = dble(mo_integrals_n_e_kpts(i,i,k))
+      enddo
+    enddo
+  else
+    PROVIDE mo_integrals_n_e
+    do i=1,mo_num
+      mo_integrals_n_e_diag(i) = mo_integrals_n_e(i,i)
+    enddo
+  endif
+END_PROVIDER

src/mo_one_e_ints/pot_mo_ints_cplx.irp.f

@@ -0,0 +1,59 @@
+BEGIN_PROVIDER [complex*16, mo_integrals_n_e_complex, (mo_num,mo_num)]
+  implicit none
+  BEGIN_DOC
+  !  Kinetic energy integrals in the MO basis
+  END_DOC
+  integer :: i,j
+  
+  print *, 'Providing MO N-e integrals'
+  if (read_mo_integrals_e_n) then
+    call ezfio_get_mo_one_e_ints_mo_integrals_e_n_complex(mo_integrals_n_e_complex)
+    print *,  'MO N-e integrals read from disk'
+  else
+  print *, 'Providing MO N-e integrals from AO N-e integrals'
+    call ao_to_mo_complex(                                            &
+        ao_integrals_n_e_complex,                                 &
+        size(ao_integrals_n_e_complex,1),                         &
+        mo_integrals_n_e_complex,                                 &
+        size(mo_integrals_n_e_complex,1)                          &
+        )
+  endif
+  if (write_mo_integrals_e_n) then
+    call ezfio_set_mo_one_e_ints_mo_integrals_e_n_complex(mo_integrals_n_e_complex)
+    print *,  'MO N-e integrals written to disk'
+  endif
+
+END_PROVIDER
+
+!============================================!
+!                                            !
+!                    kpts                    !
+!                                            !
+!============================================!
+
+BEGIN_PROVIDER [complex*16, mo_integrals_n_e_kpts, (mo_num_per_kpt,mo_num_per_kpt,kpt_num)]
+  implicit none
+  BEGIN_DOC
+  !  Kinetic energy integrals in the MO basis
+  END_DOC
+  integer :: i,j
+  
+  print *, 'Providing MO N-e integrals'
+  if (read_mo_integrals_e_n) then
+    call ezfio_get_mo_one_e_ints_mo_integrals_e_n_kpts(mo_integrals_n_e_kpts)
+    print *,  'MO N-e integrals read from disk'
+  else
+  print *, 'Providing MO N-e integrals from AO N-e integrals'
+    call ao_to_mo_kpts(                                            &
+        ao_integrals_n_e_kpts,                                 &
+        size(ao_integrals_n_e_kpts,1),                         &
+        mo_integrals_n_e_kpts,                                 &
+        size(mo_integrals_n_e_kpts,1)                          &
+        )
+  endif
+  if (write_mo_integrals_e_n) then
+    call ezfio_set_mo_one_e_ints_mo_integrals_e_n_kpts(mo_integrals_n_e_kpts)
+    print *,  'MO N-e integrals written to disk'
+  endif
+
+END_PROVIDER

src/mo_one_e_ints/pot_mo_pseudo_ints.irp.f

@@ -25,4 +25,27 @@ BEGIN_PROVIDER [double precision, mo_pseudo_integrals, (mo_num,mo_num)]
 
 END_PROVIDER
 
+BEGIN_PROVIDER [ double precision, mo_pseudo_integrals_diag,(mo_num)]
+  implicit none
+  integer                        :: i
+  BEGIN_DOC
+  ! diagonal elements of mo_pseudo_integrals or mo_pseudo_integrals_complex
+  END_DOC
+  
+  if (is_complex) then
+    integer :: k,i_shft
+    PROVIDE mo_pseudo_integrals_kpts
+    do k=1,kpt_num
+      i_shft = (k-1)*mo_num_per_kpt
+      do i=1,mo_num_per_kpt
+        mo_pseudo_integrals_diag(i+i_shft) = dble(mo_pseudo_integrals_kpts(i,i,k))
+      enddo
+    enddo
+  else
+    PROVIDE mo_pseudo_integrals
+    do i=1,mo_num
+      mo_pseudo_integrals_diag(i) = mo_pseudo_integrals(i,i)
+    enddo
+  endif
+END_PROVIDER
 

src/mo_one_e_ints/pot_mo_pseudo_ints_cplx.irp.f

@@ -0,0 +1,59 @@
+BEGIN_PROVIDER [complex*16, mo_pseudo_integrals_complex, (mo_num,mo_num)]
+  implicit none
+  BEGIN_DOC
+  ! Pseudopotential integrals in |MO| basis
+  END_DOC
+  integer :: i,j
+
+  if (read_mo_integrals_pseudo) then
+    call ezfio_get_mo_one_e_ints_mo_integrals_pseudo_complex(mo_pseudo_integrals_complex)
+    print *,  'MO pseudopotential integrals read from disk'
+  else if (do_pseudo) then
+    call ao_to_mo_complex(                                            &
+        ao_pseudo_integrals_complex,                                 &
+        size(ao_pseudo_integrals_complex,1),                         &
+        mo_pseudo_integrals_complex,                                 &
+        size(mo_pseudo_integrals_complex,1)                          &
+        )
+  else
+    mo_pseudo_integrals_complex = (0.d0,0.d0)
+  endif
+  if (write_mo_integrals_pseudo) then
+    call ezfio_set_mo_one_e_ints_mo_integrals_pseudo_complex(mo_pseudo_integrals_complex)
+    print *,  'MO pseudopotential integrals written to disk'
+  endif
+
+END_PROVIDER
+
+!============================================!
+!                                            !
+!                    kpts                    !
+!                                            !
+!============================================!
+
+BEGIN_PROVIDER [complex*16, mo_pseudo_integrals_kpts, (mo_num_per_kpt,mo_num_per_kpt,kpt_num)]
+  implicit none
+  BEGIN_DOC
+  ! Pseudopotential integrals in |MO| basis
+  END_DOC
+  integer :: i,j
+
+  if (read_mo_integrals_pseudo) then
+    call ezfio_get_mo_one_e_ints_mo_integrals_pseudo_kpts(mo_pseudo_integrals_kpts)
+    print *,  'MO pseudopotential integrals read from disk'
+  else if (do_pseudo) then
+    call ao_to_mo_kpts(                                            &
+        ao_pseudo_integrals_kpts,                                 &
+        size(ao_pseudo_integrals_kpts,1),                         &
+        mo_pseudo_integrals_kpts,                                 &
+        size(mo_pseudo_integrals_kpts,1)                          &
+        )
+  else
+    mo_pseudo_integrals_kpts = (0.d0,0.d0)
+  endif
+  if (write_mo_integrals_pseudo) then
+    call ezfio_set_mo_one_e_ints_mo_integrals_pseudo_kpts(mo_pseudo_integrals_kpts)
+    print *,  'MO pseudopotential integrals written to disk'
+  endif
+
+END_PROVIDER

src/mo_two_e_ints/EZFIO.cfg

@@ -11,3 +11,15 @@ interface: ezfio,provider,ocaml
 default: 1.e-15
 ezfio_name: threshold_mo
 
+[io_df_mo_integrals]
+type: Disk_access
+doc: Read/Write df |MO| integrals from/to disk [ Write | Read | None ] 
+interface: ezfio,provider,ocaml
+default: None
+
+[df_mo_integrals_complex]
+type: double precision
+doc: Complex df integrals over MOs
+size: (2,mo_basis.mo_num_per_kpt,mo_basis.mo_num_per_kpt,ao_two_e_ints.df_num,nuclei.kpt_pair_num)
+interface: ezfio
+

src/mo_two_e_ints/core_quantities.irp.f

@@ -7,7 +7,7 @@ BEGIN_PROVIDER [double precision, core_energy]
  core_energy = 0.d0
  do i = 1, n_core_orb
   j = list_core(i)
-  core_energy += 2.d0 * mo_one_e_integrals(j,j) + mo_two_e_integrals_jj(j,j)
+  core_energy += 2.d0 * mo_one_e_integrals_diag(j) + mo_two_e_integrals_jj(j,j)
   do k = i+1, n_core_orb
    l = list_core(k)
    core_energy += 2.d0 * (2.d0 * mo_two_e_integrals_jj(j,l) - mo_two_e_integrals_jj_exchange(j,l))
@@ -36,3 +36,25 @@ BEGIN_PROVIDER [double precision, core_fock_operator, (mo_num,mo_num)]
   enddo
  enddo
 END_PROVIDER
+
+BEGIN_PROVIDER [complex*16, core_fock_operator_complex, (mo_num,mo_num)]
+ implicit none
+ integer :: i,j,k,l,m,n
+ complex*16 :: get_two_e_integral_complex
+ BEGIN_DOC
+! this is the contribution to the Fock operator from the core electrons
+ END_DOC
+ core_fock_operator_complex = (0.d0,0.d0)
+ do i = 1, n_act_orb
+  j = list_act(i)
+  do k = 1, n_act_orb
+   l = list_act(k)
+   do m = 1, n_core_orb
+    n = list_core(m)
+    core_fock_operator_complex(j,l) += 2.d0 * &
+                    get_two_e_integral_complex(j,n,l,n,mo_integrals_map,mo_integrals_map_2) - &
+                    get_two_e_integral_complex(j,n,n,l,mo_integrals_map,mo_integrals_map_2)
+   enddo
+  enddo
+ enddo
+END_PROVIDER

src/mo_two_e_ints/df_mo_ints.irp.f

@@ -0,0 +1,295 @@
+BEGIN_PROVIDER [complex*16, df_mo_integrals_complex, (mo_num_per_kpt,mo_num_per_kpt,df_num,kpt_pair_num)]
+  implicit none
+  BEGIN_DOC
+  !  df MO integrals
+  END_DOC
+  integer :: i,j,k,l
+
+  if (read_df_mo_integrals) then
+    call ezfio_get_mo_two_e_ints_df_mo_integrals_complex(df_mo_integrals_complex)
+    print *,  'df MO integrals read from disk'
+  else
+    call df_mo_from_df_ao(df_mo_integrals_complex,df_ao_integrals_complex,mo_num_per_kpt,ao_num_per_kpt,df_num,kpt_pair_num)
+  endif
+
+  if (write_df_mo_integrals) then
+    call ezfio_set_mo_two_e_ints_df_mo_integrals_complex(df_mo_integrals_complex)
+    print *,  'df MO integrals written to disk'
+  endif
+
+END_PROVIDER
+
+subroutine mo_map_fill_from_df
+  use map_module
+  implicit none
+  BEGIN_DOC
+  ! fill mo bielec integral map using 3-index df integrals
+  END_DOC
+
+  integer :: i,k,j,l
+  integer :: ki,kk,kj,kl
+  integer :: ii,ik,ij,il
+  integer :: kikk2,kjkl2,jl2,ik2
+  integer :: i_mo,j_mo,i_df
+
+  complex*16,allocatable :: ints_ik(:,:,:), ints_jl(:,:,:), ints_ikjl(:,:,:,:)
+
+  complex*16 :: integral
+  integer                        :: n_integrals_1, n_integrals_2
+  integer                        :: size_buffer
+  integer(key_kind),allocatable  :: buffer_i_1(:), buffer_i_2(:)
+  real(integral_kind),allocatable :: buffer_values_1(:), buffer_values_2(:)
+  double precision               :: tmp_re,tmp_im
+  integer                        :: mo_num_kpt_2
+
+  double precision               :: cpu_1, cpu_2, wall_1, wall_2, wall_0
+  double precision               :: map_mb
+
+  logical :: use_map1
+  integer(keY_kind) :: idx_tmp
+  double precision :: sign
+
+  mo_num_kpt_2 = mo_num_per_kpt * mo_num_per_kpt
+
+  size_buffer = min(mo_num_per_kpt*mo_num_per_kpt*mo_num_per_kpt,16000000)
+  print*, 'Providing the mo_bielec integrals from 3-index df integrals'
+  call write_time(6)
+!  call ezfio_set_integrals_bielec_disk_access_mo_integrals('Write')
+!  TOUCH read_mo_integrals read_ao_integrals write_mo_integrals write_ao_integrals 
+
+  call wall_time(wall_1)
+  call cpu_time(cpu_1)
+
+  allocate( ints_jl(mo_num_per_kpt,mo_num_per_kpt,df_num))
+
+  wall_0 = wall_1
+  do kl=1, kpt_num
+    do kj=1, kl
+      call idx2_tri_int(kj,kl,kjkl2)
+      if (kj < kl) then
+        do i_mo=1,mo_num_per_kpt
+          do j_mo=1,mo_num_per_kpt
+            do i_df=1,df_num
+              ints_jl(i_mo,j_mo,i_df) = dconjg(df_mo_integrals_complex(j_mo,i_mo,i_df,kjkl2))
+            enddo
+          enddo
+        enddo
+      else
+        ints_jl = df_mo_integrals_complex(:,:,:,kjkl2)
+      endif
+
+  !$OMP PARALLEL PRIVATE(i,k,j,l,ki,kk,ii,ik,ij,il,kikk2,jl2,ik2, &
+      !$OMP  ints_ik, ints_ikjl, i_mo, j_mo, i_df, &
+      !$OMP  n_integrals_1, buffer_i_1, buffer_values_1, &
+      !$OMP  n_integrals_2, buffer_i_2, buffer_values_2, &
+      !$OMP  idx_tmp, tmp_re, tmp_im, integral,sign,use_map1) &
+      !$OMP  DEFAULT(NONE)  &
+      !$OMP  SHARED(size_buffer, kpt_num, df_num, mo_num_per_kpt, mo_num_kpt_2, &
+      !$OMP  kl,kj,kjkl2,ints_jl, & 
+      !$OMP  kconserv, df_mo_integrals_complex, mo_integrals_threshold, mo_integrals_map, mo_integrals_map_2)
+  
+  allocate( &
+    ints_ik(mo_num_per_kpt,mo_num_per_kpt,df_num), &
+    ints_ikjl(mo_num_per_kpt,mo_num_per_kpt,mo_num_per_kpt,mo_num_per_kpt), &
+    buffer_i_1(size_buffer), &
+    buffer_i_2(size_buffer), &
+    buffer_values_1(size_buffer), &
+    buffer_values_2(size_buffer) &
+  )
+
+  !$OMP DO SCHEDULE(guided)
+      do kk=1,kl
+        ki=kconserv(kl,kk,kj)
+        if (ki>kl) cycle
+      !  if ((kl == kj) .and. (ki > kk)) cycle
+        call idx2_tri_int(ki,kk,kikk2)
+      !  if (kikk2 > kjkl2) cycle
+        if (ki < kk) then
+          do i_mo=1,mo_num_per_kpt
+            do j_mo=1,mo_num_per_kpt
+              do i_df=1,df_num
+                ints_ik(i_mo,j_mo,i_df) = dconjg(df_mo_integrals_complex(j_mo,i_mo,i_df,kikk2))
+              enddo
+            enddo
+          enddo
+!          ints_ik = conjg(reshape(df_mo_integral_array(:,:,:,kikk2),(/mo_num_per_kpt,mo_num_per_kpt,df_num/),order=(/2,1,3/)))
+        else
+          ints_ik = df_mo_integrals_complex(:,:,:,kikk2)
+        endif
+
+        call zgemm('N','T', mo_num_kpt_2, mo_num_kpt_2, df_num, &
+               (1.d0,0.d0), ints_ik, mo_num_kpt_2, &
+               ints_jl, mo_num_kpt_2, &
+               (0.d0,0.d0), ints_ikjl, mo_num_kpt_2)
+
+        n_integrals_1=0
+        n_integrals_2=0
+        do il=1,mo_num_per_kpt
+          l=il+(kl-1)*mo_num_per_kpt
+          do ij=1,mo_num_per_kpt
+            j=ij+(kj-1)*mo_num_per_kpt
+            if (j>l) exit
+            call idx2_tri_int(j,l,jl2)
+            do ik=1,mo_num_per_kpt
+              k=ik+(kk-1)*mo_num_per_kpt
+              if (k>l) exit
+              do ii=1,mo_num_per_kpt
+                i=ii+(ki-1)*mo_num_per_kpt
+                if ((j==l) .and. (i>k)) exit
+                call idx2_tri_int(i,k,ik2)
+                if (ik2 > jl2) exit
+                integral = ints_ikjl(ii,ik,ij,il)
+!                print*,i,k,j,l,real(integral),imag(integral)
+                if (cdabs(integral) < mo_integrals_threshold) then
+                  cycle
+                endif
+                call ao_two_e_integral_complex_map_idx_sign(i,j,k,l,use_map1,idx_tmp,sign)
+                tmp_re = dble(integral)
+                tmp_im = dimag(integral)
+                if (use_map1) then
+                  n_integrals_1 += 1
+                  buffer_i_1(n_integrals_1)=idx_tmp
+                  buffer_values_1(n_integrals_1)=tmp_re
+                  if (sign.ne.0.d0) then 
+                    n_integrals_1 += 1
+                    buffer_i_1(n_integrals_1)=idx_tmp+1
+                    buffer_values_1(n_integrals_1)=tmp_im*sign
+                  endif 
+                  if (n_integrals_1 >= size(buffer_i_1)-1) then
+                    call map_append(mo_integrals_map, buffer_i_1, buffer_values_1, n_integrals_1)
+                    !call insert_into_ao_integrals_map(n_integrals_1,buffer_i_1,buffer_values_1)
+                    n_integrals_1 = 0
+                  endif
+                else
+                  n_integrals_2 += 1
+                  buffer_i_2(n_integrals_2)=idx_tmp
+                  buffer_values_2(n_integrals_2)=tmp_re
+                  if (sign.ne.0.d0) then
+                    n_integrals_2 += 1
+                    buffer_i_2(n_integrals_2)=idx_tmp+1
+                    buffer_values_2(n_integrals_2)=tmp_im*sign
+                  endif 
+                  if (n_integrals_2 >= size(buffer_i_2)-1) then
+                    call map_append(mo_integrals_map_2, buffer_i_2, buffer_values_2, n_integrals_2)
+                    !call insert_into_ao_integrals_map_2(n_integrals_2,buffer_i_2,buffer_values_2)
+                    n_integrals_2 = 0
+                  endif
+                endif
+
+              enddo !ii
+            enddo !ik
+          enddo !ij
+        enddo !il
+
+        if (n_integrals_1 > 0) then
+          call map_append(mo_integrals_map, buffer_i_1, buffer_values_1, n_integrals_1)
+          !call insert_into_ao_integrals_map(n_integrals_1,buffer_i_1,buffer_values_1)
+        endif
+        if (n_integrals_2 > 0) then
+          call map_append(mo_integrals_map_2, buffer_i_2, buffer_values_2, n_integrals_2)
+          !call insert_into_ao_integrals_map_2(n_integrals_2,buffer_i_2,buffer_values_2)
+        endif
+      enddo !kk
+  !$OMP END DO NOWAIT
+  deallocate( &
+    ints_ik, &
+    ints_ikjl, &
+    buffer_i_1, &
+    buffer_i_2, &
+    buffer_values_1, &
+    buffer_values_2 &
+    )
+  !$OMP END PARALLEL
+    enddo !kj
+    call wall_time(wall_2)
+    if (wall_2 - wall_0 > 1.d0) then
+      wall_0 = wall_2
+      print*, 100.*float(kl)/float(kpt_num), '% in ',               &
+          wall_2-wall_1,'s',map_mb(mo_integrals_map),'+',map_mb(mo_integrals_map_2),'MB'
+    endif
+
+  enddo !kl
+  deallocate( ints_jl ) 
+
+  call map_sort(mo_integrals_map)
+  call map_unique(mo_integrals_map)
+  call map_sort(mo_integrals_map_2)
+  call map_unique(mo_integrals_map_2)
+  !call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints_complex_1',mo_integrals_map)
+  !call map_save_to_disk(trim(ezfio_filename)//'/work/mo_ints_complex_2',mo_integrals_map_2)
+  !call ezfio_set_mo_two_e_ints_io_mo_two_e_integrals('Read')
+  
+  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()
+  
+  print*,'MO integrals provided:'
+  print*,' Size of MO map           ', map_mb(mo_integrals_map),'+',map_mb(mo_integrals_map_2),'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 subroutine mo_map_fill_from_df
+
+subroutine df_mo_from_df_ao(df_mo,df_ao,n_mo,n_ao,n_df,n_k_pairs)
+  use map_module
+  implicit none
+  BEGIN_DOC
+  ! create 3-idx mo ints from 3-idx ao ints
+  END_DOC
+  integer,intent(in) :: n_mo,n_ao,n_df,n_k_pairs
+  complex*16,intent(out) :: df_mo(n_mo,n_mo,n_df,n_k_pairs)
+  complex*16,intent(in)  :: df_ao(n_ao,n_ao,n_df,n_k_pairs)
+  integer :: kl,kj,kjkl2,mu,p,q
+  complex*16,allocatable :: coef_l(:,:), coef_j(:,:), ints_jl(:,:), ints_tmp(:,:)
+  double precision :: wall_1,wall_2,cpu_1,cpu_2
+
+  print*,'providing 3-index MO integrals from 3-index AO integrals'
+
+  call wall_time(wall_1)
+  call cpu_time(cpu_1)
+  allocate( &
+              coef_l(n_ao,n_mo),&
+              coef_j(n_ao,n_mo),&
+             ints_jl(n_ao,n_ao),&
+            ints_tmp(n_mo,n_ao)&
+          )
+
+  do kl=1, kpt_num
+    coef_l = mo_coef_complex_kpts(:,:,kl)
+    do kj=1, kl
+      coef_j = mo_coef_complex_kpts(:,:,kj)
+      kjkl2 = kj+shiftr(kl*kl-kl,1)
+      do mu=1, df_num
+        ints_jl = df_ao(:,:,mu,kjkl2)
+        call zgemm('C','N',n_mo,n_ao,n_ao, &
+              (1.d0,0.d0), coef_l, n_ao, &
+              ints_jl, n_ao, &
+              (0.d0,0.d0), ints_tmp, n_mo)
+
+        call zgemm('N','N',n_mo,n_mo,n_ao, &
+              (1.d0,0.d0), ints_tmp, n_mo, &
+              coef_j, n_ao, &
+              (0.d0,0.d0), df_mo(:,:,mu,kjkl2), n_mo)
+      enddo
+    enddo
+    call wall_time(wall_2)
+    print*,100.*float(kl*(kl+1))/(2.*n_k_pairs), '% in ', &
+                wall_2-wall_1, 's'
+  enddo
+
+  deallocate( &
+            coef_l, &
+            coef_j, &
+            ints_jl, &
+            ints_tmp &
+          )
+  call wall_time(wall_2)
+  call cpu_time(cpu_2)
+  print*,' 3-idx MO provided'
+  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 subroutine df_mo_from_df_ao