1!--------------------------------------------------------------------------------------------------! 2! CP2K: A general program to perform molecular dynamics simulations ! 3! Copyright (C) 2000 - 2020 CP2K developers group ! 4!--------------------------------------------------------------------------------------------------! 5 6! ************************************************************************************************** 7!> \brief Does all kind of post scf calculations for GPW/GAPW 8!> \par History 9!> Started as a copy from the relevant part of qs_scf 10!> \author Joost VandeVondele (10.2003) 11! ************************************************************************************************** 12MODULE qs_scf_wfn_mix 13 USE cp_dbcsr_operations, ONLY: copy_fm_to_dbcsr 14 USE cp_fm_basic_linalg, ONLY: cp_fm_scale_and_add 15 USE cp_fm_struct, ONLY: cp_fm_struct_create,& 16 cp_fm_struct_release,& 17 cp_fm_struct_type 18 USE cp_fm_types, ONLY: cp_fm_create,& 19 cp_fm_p_type,& 20 cp_fm_release,& 21 cp_fm_to_fm,& 22 cp_fm_type 23 USE dbcsr_api, ONLY: dbcsr_p_type 24 USE input_section_types, ONLY: section_vals_get,& 25 section_vals_get_subs_vals,& 26 section_vals_type,& 27 section_vals_val_get 28 USE kinds, ONLY: dp 29 USE particle_types, ONLY: particle_type 30 USE qs_kind_types, ONLY: qs_kind_type 31 USE qs_mo_io, ONLY: write_mo_set 32 USE qs_mo_methods, ONLY: calculate_orthonormality 33 USE qs_mo_types, ONLY: deallocate_mo_set,& 34 duplicate_mo_set,& 35 mo_set_p_type 36 USE qs_scf_types, ONLY: qs_scf_env_type,& 37 special_diag_method_nr 38#include "./base/base_uses.f90" 39 40 IMPLICIT NONE 41 PRIVATE 42 43 ! Global parameters 44 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'qs_scf_wfn_mix' 45 PUBLIC :: wfn_mix 46 47CONTAINS 48 49! ************************************************************************************************** 50!> \brief writes a new 'mixed' set of mos to restart file, without touching the current MOs 51!> \param mos ... 52!> \param particle_set ... 53!> \param dft_section ... 54!> \param qs_kind_set ... 55!> \param unoccupied_orbs ... 56!> \param scf_env ... 57!> \param matrix_s ... 58!> \param output_unit ... 59!> \param marked_states ... 60! ************************************************************************************************** 61 SUBROUTINE wfn_mix(mos, particle_set, dft_section, qs_kind_set, & 62 unoccupied_orbs, scf_env, matrix_s, output_unit, marked_states) 63 64 TYPE(mo_set_p_type), DIMENSION(:), POINTER :: mos 65 TYPE(particle_type), DIMENSION(:), POINTER :: particle_set 66 TYPE(section_vals_type), POINTER :: dft_section 67 TYPE(qs_kind_type), DIMENSION(:), POINTER :: qs_kind_set 68 TYPE(cp_fm_p_type), DIMENSION(:), POINTER :: unoccupied_orbs 69 TYPE(qs_scf_env_type), POINTER :: scf_env 70 TYPE(dbcsr_p_type), DIMENSION(:), POINTER :: matrix_s 71 INTEGER :: output_unit 72 INTEGER, DIMENSION(:, :, :), OPTIONAL, POINTER :: marked_states 73 74 CHARACTER(len=*), PARAMETER :: routineN = 'wfn_mix', routineP = moduleN//':'//routineN 75 76 INTEGER :: handle, i_rep, ispin, mark_ind, mark_number, n_rep, orig_mo_index, & 77 orig_spin_index, result_mo_index, result_spin_index 78 LOGICAL :: explicit, orig_is_virtual, overwrite_mos 79 REAL(KIND=dp) :: orig_scale, orthonormality, result_scale 80 TYPE(cp_fm_struct_type), POINTER :: fm_struct_vector 81 TYPE(cp_fm_type), POINTER :: matrix_x, matrix_y 82 TYPE(mo_set_p_type), DIMENSION(:), POINTER :: mos_new 83 TYPE(section_vals_type), POINTER :: update_section, wfn_mix_section 84 85 CALL timeset(routineN, handle) 86 wfn_mix_section => section_vals_get_subs_vals(dft_section, "PRINT%WFN_MIX") 87 CALL section_vals_get(wfn_mix_section, explicit=explicit) 88 89 ! only perform action if explicitly required 90 IF (explicit) THEN 91 92 IF (output_unit > 0) THEN 93 WRITE (output_unit, '()') 94 WRITE (output_unit, '(T2,A)') "Performing wfn mixing" 95 WRITE (output_unit, '(T2,A)') "=====================" 96 ENDIF 97 98 ALLOCATE (mos_new(SIZE(mos))) 99 DO ispin = 1, SIZE(mos) 100 CALL duplicate_mo_set(mos_new(ispin)%mo_set, mos(ispin)%mo_set) 101 ENDDO 102 103 ! a single vector matrix structure 104 NULLIFY (fm_struct_vector) 105 CALL cp_fm_struct_create(fm_struct_vector, template_fmstruct=mos(1)%mo_set%mo_coeff%matrix_struct, & 106 ncol_global=1) 107 CALL cp_fm_create(matrix_x, fm_struct_vector, name="x") 108 CALL cp_fm_create(matrix_y, fm_struct_vector, name="y") 109 CALL cp_fm_struct_release(fm_struct_vector) 110 111 update_section => section_vals_get_subs_vals(wfn_mix_section, "UPDATE") 112 CALL section_vals_get(update_section, n_repetition=n_rep) 113 CALL section_vals_get(update_section, explicit=explicit) 114 IF (.NOT. explicit) n_rep = 0 115 116 DO i_rep = 1, n_rep 117 118 CALL section_vals_val_get(update_section, "RESULT_MO_INDEX", i_rep_section=i_rep, i_val=result_mo_index) 119 CALL section_vals_val_get(update_section, "RESULT_MARKED_STATE", i_rep_section=i_rep, i_val=mark_number) 120 CALL section_vals_val_get(update_section, "RESULT_SPIN_INDEX", i_rep_section=i_rep, i_val=result_spin_index) 121 CALL section_vals_val_get(update_section, "RESULT_SCALE", i_rep_section=i_rep, r_val=result_scale) 122 123 mark_ind = 1 124 IF (mark_number .GT. 0) result_mo_index = marked_states(mark_number, result_spin_index, mark_ind) 125 126 CALL section_vals_val_get(update_section, "ORIG_MO_INDEX", i_rep_section=i_rep, i_val=orig_mo_index) 127 CALL section_vals_val_get(update_section, "ORIG_MARKED_STATE", i_rep_section=i_rep, i_val=mark_number) 128 CALL section_vals_val_get(update_section, "ORIG_SPIN_INDEX", i_rep_section=i_rep, i_val=orig_spin_index) 129 CALL section_vals_val_get(update_section, "ORIG_SCALE", i_rep_section=i_rep, r_val=orig_scale) 130 CALL section_vals_val_get(update_section, "ORIG_IS_VIRTUAL", i_rep_section=i_rep, l_val=orig_is_virtual) 131 132 IF (orig_is_virtual) mark_ind = 2 133 IF (mark_number .GT. 0) orig_mo_index = marked_states(mark_number, orig_spin_index, mark_ind) 134 135 CALL section_vals_val_get(wfn_mix_section, "OVERWRITE_MOS", l_val=overwrite_mos) 136 137 ! first get a copy of the proper orig 138 IF (.NOT. ORIG_IS_VIRTUAL) THEN 139 CALL cp_fm_to_fm(mos(orig_spin_index)%mo_set%mo_coeff, matrix_x, 1, & 140 mos(orig_spin_index)%mo_set%nmo - orig_mo_index + 1, 1) 141 ELSE 142 CALL cp_fm_to_fm(unoccupied_orbs(orig_spin_index)%matrix, matrix_x, 1, orig_mo_index, 1) 143 ENDIF 144 145 ! now get a copy of the target 146 CALL cp_fm_to_fm(mos_new(result_spin_index)%mo_set%mo_coeff, matrix_y, & 147 1, mos_new(result_spin_index)%mo_set%nmo - result_mo_index + 1, 1) 148 149 ! properly mix 150 CALL cp_fm_scale_and_add(result_scale, matrix_y, orig_scale, matrix_x) 151 152 ! and copy back in the result mos 153 CALL cp_fm_to_fm(matrix_y, mos_new(result_spin_index)%mo_set%mo_coeff, & 154 1, 1, mos_new(result_spin_index)%mo_set%nmo - result_mo_index + 1) 155 156 ENDDO 157 158 CALL cp_fm_release(matrix_x) 159 CALL cp_fm_release(matrix_y) 160 161 IF (scf_env%method == special_diag_method_nr) THEN 162 CALL calculate_orthonormality(orthonormality, mos) 163 ELSE 164 CALL calculate_orthonormality(orthonormality, mos, matrix_s(1)%matrix) 165 END IF 166 167 IF (output_unit > 0) THEN 168 WRITE (output_unit, '()') 169 WRITE (output_unit, '(T2,A,T61,E20.4)') & 170 "Maximum deviation from MO S-orthonormality", orthonormality 171 WRITE (output_unit, '(T2,A)') "Writing new MOs to file" 172 ENDIF 173 174 ! *** Write WaveFunction restart file *** 175 176 DO ispin = 1, SIZE(mos_new) 177 IF (overwrite_mos) THEN 178 CALL cp_fm_to_fm(mos_new(ispin)%mo_set%mo_coeff, mos(ispin)%mo_set%mo_coeff) 179 IF (mos_new(1)%mo_set%use_mo_coeff_b) & 180 CALL copy_fm_to_dbcsr(mos_new(ispin)%mo_set%mo_coeff, mos_new(ispin)%mo_set%mo_coeff_b) 181 END IF 182 IF (mos(1)%mo_set%use_mo_coeff_b) & 183 CALL copy_fm_to_dbcsr(mos_new(ispin)%mo_set%mo_coeff, mos(ispin)%mo_set%mo_coeff_b) 184 END DO 185 CALL write_mo_set(mos_new, particle_set, dft_section=dft_section, qs_kind_set=qs_kind_set) 186 187 DO ispin = 1, SIZE(mos_new) 188 CALL deallocate_mo_set(mos_new(ispin)%mo_set) 189 ENDDO 190 DEALLOCATE (mos_new) 191 192 ENDIF 193 194 CALL timestop(handle) 195 196 END SUBROUTINE wfn_mix 197 198END MODULE qs_scf_wfn_mix 199