|
CP2K 2.4 (Revision 12889)
|
00001 !-----------------------------------------------------------------------------! 00002 ! CP2K: A general program to perform molecular dynamics simulations ! 00003 ! Copyright (C) 2000 - 2013 CP2K developers group ! 00004 !-----------------------------------------------------------------------------! 00005 00006 ! ***************************************************************************** 00010 MODULE qs_linres_types 00011 USE atomic_kind_types, ONLY: atomic_kind_type,& 00012 get_atomic_kind,& 00013 get_atomic_kind_set 00014 USE basis_set_types, ONLY: get_gto_basis_set,& 00015 gto_basis_set_type 00016 USE cp_array_i_utils, ONLY: cp_2d_i_p_type 00017 USE cp_array_r_utils, ONLY: cp_2d_r_p_type 00018 USE cp_dbcsr_types, ONLY: cp_dbcsr_p_type 00019 USE cp_fm_types, ONLY: cp_fm_p_type 00020 USE f77_blas 00021 USE kinds, ONLY: dp 00022 USE qs_grid_atom, ONLY: grid_atom_type 00023 USE qs_harmonics_atom, ONLY: harmonics_atom_type 00024 USE qs_loc_types, ONLY: qs_loc_env_new_type,& 00025 qs_loc_env_release 00026 USE qs_rho_atom_types, ONLY: rho_atom_coeff,& 00027 rho_atom_type 00028 USE qs_rho_types, ONLY: qs_rho_p_type,& 00029 qs_rho_release 00030 USE realspace_grid_types, ONLY: realspace_grid_p_type 00031 USE timings, ONLY: timeset,& 00032 timestop 00033 #include "cp_common_uses.h" 00034 00035 IMPLICIT NONE 00036 00037 00038 PRIVATE 00039 00040 !****s* qs_linres_types/linres_control_type 00041 00042 ! ***************************************************************************** 00052 TYPE linres_control_type 00053 INTEGER :: ref_count 00054 INTEGER :: property 00055 INTEGER :: preconditioner_type 00056 INTEGER :: restart_every 00057 REAL(dp) :: energy_gap 00058 INTEGER :: max_iter 00059 LOGICAL :: localized_psi0 00060 LOGICAL :: do_kernel 00061 LOGICAL :: converged 00062 LOGICAL :: linres_restart 00063 LOGICAL :: lr_triplet 00064 REAL(KIND=dp) :: eps 00065 TYPE(qs_loc_env_new_type), POINTER :: qs_loc_env 00066 CHARACTER(LEN=8) :: flag 00067 END TYPE linres_control_type 00068 00069 !****s* qs_linres_types/current_env_type 00070 00071 ! ***************************************************************************** 00095 TYPE realspaces_grid_p_type 00096 TYPE(realspace_grid_p_type), DIMENSION(:), POINTER :: rs 00097 END TYPE realspaces_grid_p_type 00098 00099 TYPE current_env_type 00100 LOGICAL :: full,simple_done(6),simple_converged(6),do_qmmm 00101 LOGICAL :: use_old_gauge_atom,chi_pbc,do_selected_states, 00102 gauge_init, all_pert_op_done 00103 LOGICAL, DIMENSION(:,:), POINTER :: full_done 00104 INTEGER :: ref_count,nao,nstates(2),gauge,orb_center,nbr_center(2) 00105 INTEGER, DIMENSION(: ), POINTER :: list_cubes,selected_states_on_atom_list 00106 INTEGER, DIMENSION(:,:,:), POINTER :: statetrueindex 00107 CHARACTER(LEN=30) :: gauge_name,orb_center_name 00108 REAL(dp) :: chi_tensor(3,3,2),chi_tensor_loc(3,3,2),gauge_atom_radius 00109 REAL(dp) :: selected_states_atom_radius 00110 REAL(dp), DIMENSION(:,:), POINTER :: basisfun_center 00111 TYPE(cp_2d_i_p_type), DIMENSION(: ), POINTER :: center_list 00112 TYPE(cp_2d_r_p_type), DIMENSION(: ), POINTER :: centers_set 00113 TYPE(cp_fm_p_type), DIMENSION(:,:), POINTER :: psi1_p,psi1_rxp,psi1_D,p_psi0,rxp_psi0 00114 TYPE(jrho_atom_type), DIMENSION(: ), POINTER :: jrho1_atom_set 00115 TYPE(qs_rho_p_type), DIMENSION(: ), POINTER :: jrho1_set 00116 TYPE(realspace_grid_p_type),DIMENSION(:),POINTER :: rs_buf 00117 TYPE(realspaces_grid_p_type), DIMENSION(:), POINTER :: rs_gauge 00118 ! 00119 TYPE(cp_fm_p_type) , DIMENSION(:), POINTER :: psi0_order 00120 END TYPE current_env_type 00121 00122 TYPE issc_env_type 00123 INTEGER :: ref_count 00124 INTEGER :: issc_natms 00125 INTEGER, DIMENSION(:), POINTER :: issc_on_atom_list 00126 LOGICAL :: interpolate_issc 00127 LOGICAL :: do_fc,do_sd,do_pso,do_dso 00128 REAL(dp) :: issc_gapw_radius,issc_factor,issc_factor_gapw 00129 REAL(dp), DIMENSION(:,:,:,:,:), POINTER :: issc,issc_loc 00130 TYPE(cp_fm_p_type), DIMENSION(:,:), POINTER :: psi1_efg,psi1_pso,efg_psi0,pso_psi0,dso_psi0,psi1_dso!last two not needed 00131 TYPE(cp_fm_p_type), DIMENSION(:), POINTER :: psi1_fc 00132 TYPE(cp_fm_p_type), DIMENSION(:), POINTER :: fc_psi0 00133 TYPE(cp_dbcsr_p_type),DIMENSION(: ), POINTER :: matrix_efg,matrix_pso,matrix_dso,matrix_fc 00134 END TYPE issc_env_type 00135 00136 TYPE nmr_env_type 00137 INTEGER :: ref_count, n_nics 00138 INTEGER, DIMENSION(:), POINTER :: cs_atom_list 00139 INTEGER, DIMENSION(:), POINTER :: do_calc_cs_atom 00140 LOGICAL :: do_nics,interpolate_shift 00141 REAL(dp) :: shift_gapw_radius,shift_factor, shift_factor_gapw, chi_factor, 00142 chi_SI2shiftppm, chi_SI2ppmcgs 00143 REAL(dp), DIMENSION(:,: ), POINTER :: r_nics 00144 REAL(dp), DIMENSION(:,:,:), POINTER :: chemical_shift, chemical_shift_loc, 00145 chemical_shift_nics_loc, chemical_shift_nics 00146 END TYPE nmr_env_type 00147 00148 ! ***************************************************************************** 00149 TYPE epr_env_type 00150 INTEGER :: ref_count 00151 REAL(dp) :: g_free_factor, g_soo_chicorr_factor, g_soo_factor, 00152 g_so_factor, g_so_factor_gapw, g_zke_factor, g_zke 00153 REAL(dp), DIMENSION(:,:), POINTER :: g_total, g_so, g_soo 00154 TYPE(qs_rho_p_type), DIMENSION(:,:), POINTER :: nablavks_set 00155 TYPE(nablavks_atom_type), DIMENSION(: ), POINTER :: nablavks_atom_set 00156 TYPE(qs_rho_p_type), DIMENSION(:,:), POINTER :: bind_set 00157 TYPE(rho_atom_coeff), DIMENSION(:,:), POINTER :: bind_atom_set 00158 TYPE(rho_atom_type), DIMENSION(: ), POINTER :: vks_atom_set 00159 END TYPE epr_env_type 00160 00161 ! ***************************************************************************** 00162 TYPE nablavks_atom_type 00163 TYPE(rho_atom_coeff), DIMENSION(:,:), 00164 POINTER :: nablavks_vec_rad_h, 00165 nablavks_vec_rad_s 00166 END TYPE nablavks_atom_type 00167 00168 ! ***************************************************************************** 00169 TYPE jrho_atom_p_type 00170 TYPE(jrho_atom_type), POINTER :: jrho_atom 00171 END TYPE jrho_atom_p_type 00172 00173 ! ***************************************************************************** 00174 TYPE jrho_atom_type 00175 TYPE(rho_atom_coeff), DIMENSION(:), 00176 POINTER :: cjc_h, cjc_s, cjc0_h, cjc0_s 00177 TYPE(rho_atom_coeff), DIMENSION(:), 00178 POINTER :: cjc_ii_h, cjc_ii_s 00179 TYPE(rho_atom_coeff), DIMENSION(:), 00180 POINTER :: cjc_iii_h, cjc_iii_s 00181 TYPE(rho_atom_coeff), DIMENSION(:,:), 00182 POINTER :: jrho_vec_rad_h, 00183 jrho_vec_rad_s 00184 TYPE(rho_atom_coeff), DIMENSION(:), 00185 POINTER :: jrho_h, jrho_s 00186 TYPE(rho_atom_coeff), DIMENSION(:), 00187 POINTER :: jrho_a_h, jrho_a_s 00188 TYPE(rho_atom_coeff), DIMENSION(:), 00189 POINTER :: jrho_b_h, jrho_b_s 00190 TYPE(rho_atom_coeff), DIMENSION(:), 00191 POINTER :: jrho_a_h_ii, jrho_a_s_ii 00192 TYPE(rho_atom_coeff), DIMENSION(:), 00193 POINTER :: jrho_b_h_ii, jrho_b_s_ii 00194 TYPE(rho_atom_coeff), DIMENSION(:), 00195 POINTER :: jrho_a_h_iii, jrho_a_s_iii 00196 TYPE(rho_atom_coeff), DIMENSION(:), 00197 POINTER :: jrho_b_h_iii, jrho_b_s_iii 00198 END TYPE jrho_atom_type 00199 00200 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'qs_linres_types' 00201 00202 ! *** Public data types *** 00203 00204 PUBLIC :: allocate_jrho_atom_rad, deallocate_jrho_atom_set, get_nmr_env, & 00205 get_current_env, allocate_jrho_coeff, deallocate_jrho_coeff, & 00206 init_jrho_atom_set, linres_control_type, init_nablavks_atom_set, & 00207 nmr_env_type, issc_env_type, jrho_atom_type, set_nmr_env, & 00208 set2zero_jrho_atom_rad, get_epr_env, epr_env_type, set_epr_env, & 00209 nablavks_atom_type, deallocate_nablavks_atom_set, current_env_type, & 00210 set_current_env, realspaces_grid_p_type, get_issc_env, set_issc_env, & 00211 issc_env_create 00212 00213 ! *** Public subroutines *** 00214 00215 PUBLIC :: linres_control_create, linres_control_retain, linres_control_release,& 00216 nmr_env_create, epr_env_create, current_env_create 00217 00218 CONTAINS 00219 00220 ! ***************************************************************************** 00221 SUBROUTINE linres_control_create(linres_control,error) 00222 00223 TYPE(linres_control_type), POINTER :: linres_control 00224 TYPE(cp_error_type), INTENT(inout) :: error 00225 00226 CHARACTER(len=*), PARAMETER :: routineN = 'linres_control_create', 00227 routineP = moduleN//':'//routineN 00228 00229 INTEGER :: istat 00230 LOGICAL :: failure 00231 00232 failure =.FALSE. 00233 00234 CPPrecondition(.NOT.ASSOCIATED(linres_control),cp_failure_level,routineP,error,failure) 00235 IF (.NOT. failure) THEN 00236 ALLOCATE (linres_control,STAT=istat) 00237 CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) 00238 linres_control%ref_count=1 00239 NULLIFY(linres_control%qs_loc_env) 00240 linres_control%property = HUGE(0)!is that used? 00241 linres_control%preconditioner_type = HUGE(0) 00242 linres_control%restart_every = HUGE(0) 00243 linres_control%energy_gap = HUGE(0.0_dp) 00244 linres_control%max_iter = HUGE(0) 00245 linres_control%localized_psi0 = .FALSE. 00246 linres_control%converged = .FALSE. 00247 linres_control%linres_restart = .FALSE. 00248 linres_control%eps = HUGE(0.0_dp) 00249 linres_control%flag = "" 00250 linres_control%do_kernel = .FALSE. 00251 linres_control%lr_triplet = .FALSE. 00252 END IF 00253 00254 END SUBROUTINE linres_control_create 00255 00256 ! ***************************************************************************** 00257 SUBROUTINE linres_control_release(linres_control,error) 00258 00259 TYPE(linres_control_type), POINTER :: linres_control 00260 TYPE(cp_error_type), INTENT(inout) :: error 00261 00262 CHARACTER(len=*), PARAMETER :: routineN = 'linres_control_release', 00263 routineP = moduleN//':'//routineN 00264 00265 INTEGER :: istat 00266 LOGICAL :: failure 00267 00268 failure =.FALSE. 00269 00270 IF (ASSOCIATED(linres_control)) THEN 00271 CPPostcondition(linres_control%ref_count>0,cp_failure_level,routineP,error,failure) 00272 linres_control%ref_count=linres_control%ref_count-1 00273 IF(linres_control%ref_count<1)THEN 00274 IF(ASSOCIATED(linres_control%qs_loc_env)) THEN 00275 CALL qs_loc_env_release(linres_control%qs_loc_env, error=error) 00276 END IF 00277 DEALLOCATE(linres_control,STAT=istat) 00278 CPPostcondition(istat==0,cp_failure_level,routineP,error,failure) 00279 END IF 00280 END IF 00281 NULLIFY(linres_control) 00282 END SUBROUTINE linres_control_release 00283 00284 ! ***************************************************************************** 00285 SUBROUTINE linres_control_retain(linres_control,error) 00286 00287 TYPE(linres_control_type), POINTER :: linres_control 00288 TYPE(cp_error_type), INTENT(inout) :: error 00289 00290 CHARACTER(len=*), PARAMETER :: routineN = 'linres_control_retain', 00291 routineP = moduleN//':'//routineN 00292 00293 LOGICAL :: failure 00294 00295 failure =.FALSE. 00296 00297 CPPrecondition(ASSOCIATED(linres_control),cp_failure_level,routineP,error,failure) 00298 IF (.NOT. failure) THEN 00299 CPPostcondition(linres_control%ref_count>0,cp_failure_level,routineP,error,failure) 00300 linres_control%ref_count=linres_control%ref_count+1 00301 END IF 00302 00303 END SUBROUTINE linres_control_retain 00304 00305 ! ***************************************************************************** 00306 SUBROUTINE current_env_create(current_env,error) 00307 00308 TYPE(current_env_type) :: current_env 00309 TYPE(cp_error_type), INTENT(inout) :: error 00310 00311 CHARACTER(len=*), PARAMETER :: routineN = 'current_env_create', 00312 routineP = moduleN//':'//routineN 00313 00314 LOGICAL :: failure 00315 00316 failure =.FALSE. 00317 00318 CPPrecondition(current_env%ref_count==0, cp_failure_level,routineP,error,failure) 00319 IF(.NOT. failure) THEN 00320 current_env%ref_count = 1 00321 current_env%nao = HUGE(1) 00322 current_env%gauge = HUGE(1) 00323 current_env%orb_center = HUGE(1) 00324 current_env%nstates(:) = HUGE(1) 00325 current_env%nbr_center(:) = HUGE(1) 00326 current_env%use_old_gauge_atom = .TRUE. 00327 current_env%chi_pbc = .FALSE. 00328 current_env%do_selected_states = .FALSE. 00329 current_env%gauge_init = .FALSE. 00330 NULLIFY(current_env%full_done) 00331 NULLIFY(current_env%list_cubes) 00332 NULLIFY(current_env%statetrueindex) 00333 NULLIFY(current_env%basisfun_center) 00334 NULLIFY(current_env%center_list) 00335 NULLIFY(current_env%centers_set) 00336 NULLIFY(current_env%psi1_p) 00337 NULLIFY(current_env%psi1_rxp) 00338 NULLIFY(current_env%psi1_D) 00339 NULLIFY(current_env%p_psi0) 00340 NULLIFY(current_env%rxp_psi0) 00341 NULLIFY(current_env%jrho1_atom_set) 00342 NULLIFY(current_env%jrho1_set) 00343 NULLIFY(current_env%rs_gauge) 00344 NULLIFY(current_env%rs_buf) 00345 NULLIFY(current_env%selected_states_on_atom_list) 00346 NULLIFY(current_env%psi0_order) 00347 END IF 00348 00349 END SUBROUTINE current_env_create 00350 ! ***************************************************************************** 00351 SUBROUTINE nmr_env_create(nmr_env,error) 00352 00353 TYPE(nmr_env_type) :: nmr_env 00354 TYPE(cp_error_type), INTENT(inout) :: error 00355 00356 CHARACTER(len=*), PARAMETER :: routineN = 'nmr_env_create', 00357 routineP = moduleN//':'//routineN 00358 00359 LOGICAL :: failure 00360 00361 failure =.FALSE. 00362 00363 CPPrecondition(nmr_env%ref_count==0, cp_failure_level,routineP,error,failure) 00364 IF(.NOT. failure) THEN 00365 nmr_env%ref_count = 1 00366 NULLIFY(nmr_env%chemical_shift) 00367 NULLIFY(nmr_env%chemical_shift_loc) 00368 NULLIFY(nmr_env%chemical_shift_nics_loc) 00369 NULLIFY(nmr_env%chemical_shift_nics) 00370 NULLIFY(nmr_env%r_nics) 00371 NULLIFY(nmr_env%cs_atom_list) 00372 NULLIFY(nmr_env%do_calc_cs_atom) 00373 END IF 00374 00375 END SUBROUTINE nmr_env_create 00376 00377 ! ***************************************************************************** 00378 SUBROUTINE issc_env_create(issc_env,error) 00379 00380 TYPE(issc_env_type) :: issc_env 00381 TYPE(cp_error_type), INTENT(inout) :: error 00382 00383 CHARACTER(len=*), PARAMETER :: routineN = 'issc_env_create', 00384 routineP = moduleN//':'//routineN 00385 00386 LOGICAL :: failure 00387 00388 failure =.FALSE. 00389 00390 CPPrecondition(issc_env%ref_count==0, cp_failure_level,routineP,error,failure) 00391 IF(.NOT. failure) THEN 00392 issc_env%ref_count = 1 00393 NULLIFY(issc_env%issc) 00394 NULLIFY(issc_env%issc_loc) 00395 NULLIFY(issc_env%psi1_efg) 00396 NULLIFY(issc_env%psi1_fc) 00397 NULLIFY(issc_env%psi1_pso) 00398 NULLIFY(issc_env%psi1_dso) 00399 NULLIFY(issc_env%efg_psi0) 00400 NULLIFY(issc_env%pso_psi0) 00401 NULLIFY(issc_env%dso_psi0) 00402 NULLIFY(issc_env%fc_psi0) 00403 NULLIFY(issc_env%matrix_efg) 00404 NULLIFY(issc_env%matrix_pso) 00405 NULLIFY(issc_env%matrix_dso) 00406 NULLIFY(issc_env%matrix_fc) 00407 ENDIF 00408 00409 END SUBROUTINE issc_env_create 00410 00411 ! ***************************************************************************** 00412 SUBROUTINE epr_env_create(epr_env,error) 00413 00414 TYPE(epr_env_type) :: epr_env 00415 TYPE(cp_error_type), INTENT(inout), 00416 OPTIONAL :: error 00417 00418 CHARACTER(len=*), PARAMETER :: routineN = 'epr_env_create', 00419 routineP = moduleN//':'//routineN 00420 00421 LOGICAL :: failure 00422 00423 failure =.FALSE. 00424 00425 CPPrecondition(epr_env%ref_count==0, cp_failure_level,routineP,error,failure) 00426 IF(.NOT. failure) THEN 00427 epr_env%ref_count = 1 00428 NULLIFY(epr_env%nablavks_set) 00429 NULLIFY(epr_env%nablavks_atom_set) 00430 NULLIFY(epr_env%bind_set) 00431 NULLIFY(epr_env%bind_atom_set) 00432 NULLIFY(epr_env%g_total) 00433 NULLIFY(epr_env%g_so) 00434 NULLIFY(epr_env%g_soo) 00435 NULLIFY(epr_env%vks_atom_set) 00436 END IF 00437 00438 END SUBROUTINE epr_env_create 00439 00440 SUBROUTINE get_current_env(current_env,simple_done,simple_converged,full_done,ref_count,nao,& 00441 & nstates,gauge,list_cubes,statetrueindex,gauge_name,basisfun_center,& 00442 & nbr_center,center_list,centers_set,psi1_p,psi1_rxp,psi1_D,p_psi0,& 00443 & rxp_psi0,jrho1_atom_set,jrho1_set,chi_tensor,& 00444 & chi_tensor_loc,gauge_atom_radius,rs_gauge,use_old_gauge_atom,& 00445 & chi_pbc,psi0_order,error) 00446 00447 TYPE(current_env_type), OPTIONAL :: current_env 00448 LOGICAL, OPTIONAL :: simple_done(6), 00449 simple_converged(6) 00450 LOGICAL, DIMENSION(:, :), OPTIONAL, 00451 POINTER :: full_done 00452 INTEGER, OPTIONAL :: ref_count, nao, nstates(2), 00453 gauge 00454 INTEGER, DIMENSION(:), OPTIONAL, POINTER :: list_cubes 00455 INTEGER, DIMENSION(:, :, :), OPTIONAL, 00456 POINTER :: statetrueindex 00457 CHARACTER(LEN=30), OPTIONAL :: gauge_name 00458 REAL(dp), DIMENSION(:, :), OPTIONAL, 00459 POINTER :: basisfun_center 00460 INTEGER, OPTIONAL :: nbr_center(2) 00461 TYPE(cp_2d_i_p_type), DIMENSION(:), 00462 OPTIONAL, POINTER :: center_list 00463 TYPE(cp_2d_r_p_type), DIMENSION(:), 00464 OPTIONAL, POINTER :: centers_set 00465 TYPE(cp_fm_p_type), DIMENSION(:, :), 00466 OPTIONAL, POINTER :: psi1_p, psi1_rxp, psi1_D, 00467 p_psi0, rxp_psi0 00468 TYPE(jrho_atom_type), DIMENSION(:), 00469 OPTIONAL, POINTER :: jrho1_atom_set 00470 TYPE(qs_rho_p_type), DIMENSION(:), 00471 OPTIONAL, POINTER :: jrho1_set 00472 REAL(dp), INTENT(OUT), OPTIONAL :: chi_tensor(3,3,2), 00473 chi_tensor_loc(3,3,2), 00474 gauge_atom_radius 00475 TYPE(realspaces_grid_p_type), 00476 DIMENSION(:), OPTIONAL, POINTER :: rs_gauge 00477 LOGICAL, OPTIONAL :: use_old_gauge_atom, chi_pbc 00478 TYPE(cp_fm_p_type), DIMENSION(:), 00479 OPTIONAL, POINTER :: psi0_order 00480 TYPE(cp_error_type), INTENT(inout) :: error 00481 00482 CHARACTER(len=*), PARAMETER :: routineN = 'get_current_env', 00483 routineP = moduleN//':'//routineN 00484 00485 LOGICAL :: failure 00486 00487 ! 00488 ! 00489 00490 failure =.FALSE. 00491 00492 CPPrecondition(current_env%ref_count>0, cp_failure_level,routineP,error,failure) 00493 00494 IF(.NOT. failure) THEN 00495 IF(PRESENT(simple_done )) simple_done(1:6) = current_env%simple_done(1:6) 00496 IF(PRESENT(simple_converged)) simple_converged(1:6) = current_env%simple_converged(1:6) 00497 IF(PRESENT(full_done )) full_done => current_env%full_done 00498 IF(PRESENT(ref_count )) ref_count = current_env%ref_count 00499 IF(PRESENT(nao )) nao = current_env%nao 00500 IF(PRESENT(nstates )) nstates(1:2) = current_env%nstates(1:2) 00501 IF(PRESENT(gauge )) gauge = current_env%gauge 00502 IF(PRESENT(list_cubes )) list_cubes => current_env%list_cubes 00503 IF(PRESENT(statetrueindex )) statetrueindex => current_env%statetrueindex 00504 IF(PRESENT(gauge_name )) gauge_name = current_env%gauge_name 00505 IF(PRESENT(basisfun_center )) basisfun_center => current_env%basisfun_center 00506 IF(PRESENT(nbr_center )) nbr_center(1:2) = current_env%nbr_center(1:2) 00507 IF(PRESENT(center_list )) center_list => current_env%center_list 00508 IF(PRESENT(centers_set )) centers_set => current_env%centers_set 00509 IF(PRESENT(chi_tensor )) chi_tensor(:,:,:) = current_env%chi_tensor(:,:,:) 00510 IF(PRESENT(chi_tensor_loc )) chi_tensor_loc(:,:,:) = current_env%chi_tensor_loc(:,:,:) 00511 IF(PRESENT(psi1_p )) psi1_p => current_env%psi1_p 00512 IF(PRESENT(psi1_rxp )) psi1_rxp => current_env%psi1_rxp 00513 IF(PRESENT(psi1_D )) psi1_D => current_env%psi1_D 00514 IF(PRESENT(p_psi0 )) p_psi0 => current_env%p_psi0 00515 IF(PRESENT(rxp_psi0 )) rxp_psi0 => current_env%rxp_psi0 00516 IF(PRESENT(jrho1_atom_set )) jrho1_atom_set => current_env%jrho1_atom_set 00517 IF(PRESENT(jrho1_set )) jrho1_set => current_env%jrho1_set 00518 IF(PRESENT(rs_gauge )) rs_gauge => current_env%rs_gauge 00519 IF(PRESENT(psi0_order )) psi0_order => current_env%psi0_order 00520 IF(PRESENT(chi_pbc )) chi_pbc = current_env%chi_pbc 00521 IF(PRESENT(gauge_atom_radius )) gauge_atom_radius = current_env%gauge_atom_radius 00522 IF(PRESENT(use_old_gauge_atom)) use_old_gauge_atom = current_env%use_old_gauge_atom 00523 ENDIF 00524 00525 END SUBROUTINE get_current_env 00526 00527 ! ***************************************************************************** 00528 SUBROUTINE get_nmr_env(nmr_env, n_nics, cs_atom_list, do_calc_cs_atom, & 00529 r_nics, chemical_shift,chemical_shift_loc, & 00530 chemical_shift_nics_loc, chemical_shift_nics, & 00531 shift_gapw_radius,do_nics,interpolate_shift,error) 00532 00533 TYPE(nmr_env_type) :: nmr_env 00534 INTEGER, INTENT(OUT), OPTIONAL :: n_nics 00535 INTEGER, DIMENSION(:), OPTIONAL, POINTER :: cs_atom_list, do_calc_cs_atom 00536 REAL(dp), DIMENSION(:, :), OPTIONAL, 00537 POINTER :: r_nics 00538 REAL(dp), DIMENSION(:, :, :), OPTIONAL, 00539 POINTER :: chemical_shift, 00540 chemical_shift_loc, 00541 chemical_shift_nics_loc, 00542 chemical_shift_nics 00543 REAL(dp), INTENT(OUT), OPTIONAL :: shift_gapw_radius 00544 LOGICAL, INTENT(OUT), OPTIONAL :: do_nics, interpolate_shift 00545 TYPE(cp_error_type), INTENT(inout) :: error 00546 00547 CHARACTER(len=*), PARAMETER :: routineN = 'get_nmr_env', 00548 routineP = moduleN//':'//routineN 00549 00550 LOGICAL :: failure 00551 00552 failure =.FALSE. 00553 00554 CPPrecondition(nmr_env%ref_count>0, cp_failure_level,routineP,error,failure) 00555 00556 IF(PRESENT(n_nics )) n_nics = nmr_env%n_nics 00557 IF(PRESENT(cs_atom_list )) cs_atom_list => nmr_env%cs_atom_list 00558 IF(PRESENT(do_calc_cs_atom )) do_calc_cs_atom => nmr_env%do_calc_cs_atom 00559 IF(PRESENT(chemical_shift )) chemical_shift => nmr_env%chemical_shift 00560 IF(PRESENT(chemical_shift_loc )) chemical_shift_loc => nmr_env%chemical_shift_loc 00561 IF(PRESENT(chemical_shift_nics)) chemical_shift_nics => nmr_env%chemical_shift_nics 00562 IF(PRESENT(r_nics )) r_nics => nmr_env%r_nics 00563 IF(PRESENT(chemical_shift_nics_loc)) chemical_shift_nics_loc => nmr_env%chemical_shift_nics_loc 00564 IF(PRESENT(shift_gapw_radius )) shift_gapw_radius = nmr_env%shift_gapw_radius 00565 IF(PRESENT(do_nics )) do_nics = nmr_env%do_nics 00566 IF(PRESENT(interpolate_shift )) interpolate_shift = nmr_env%interpolate_shift 00567 00568 END SUBROUTINE get_nmr_env 00569 00570 ! ***************************************************************************** 00571 SUBROUTINE get_issc_env(issc_env,issc_on_atom_list,issc_gapw_radius,issc_loc,& 00572 do_fc,do_sd,do_pso,do_dso,& 00573 issc,interpolate_issc,psi1_efg,psi1_pso,psi1_dso,psi1_fc,efg_psi0,pso_psi0,dso_psi0,fc_psi0,& 00574 matrix_efg,matrix_pso,matrix_dso,matrix_fc,error) 00575 00576 TYPE(issc_env_type) :: issc_env 00577 INTEGER, DIMENSION(:), OPTIONAL, POINTER :: issc_on_atom_list 00578 REAL(dp), OPTIONAL :: issc_gapw_radius 00579 REAL(dp), DIMENSION(:, :, :, :, :), 00580 OPTIONAL, POINTER :: issc_loc 00581 LOGICAL, OPTIONAL :: do_fc, do_sd, do_pso, do_dso 00582 REAL(dp), DIMENSION(:, :, :, :, :), 00583 OPTIONAL, POINTER :: issc 00584 LOGICAL, OPTIONAL :: interpolate_issc 00585 TYPE(cp_fm_p_type), DIMENSION(:, :), 00586 OPTIONAL, POINTER :: psi1_efg, psi1_pso, psi1_dso 00587 TYPE(cp_fm_p_type), DIMENSION(:), 00588 OPTIONAL, POINTER :: psi1_fc 00589 TYPE(cp_fm_p_type), DIMENSION(:, :), 00590 OPTIONAL, POINTER :: efg_psi0, pso_psi0, dso_psi0 00591 TYPE(cp_fm_p_type), DIMENSION(:), 00592 OPTIONAL, POINTER :: fc_psi0 00593 TYPE(cp_dbcsr_p_type), DIMENSION(:), 00594 OPTIONAL, POINTER :: matrix_efg, matrix_pso, 00595 matrix_dso, matrix_fc 00596 TYPE(cp_error_type), INTENT(inout) :: error 00597 00598 CHARACTER(len=*), PARAMETER :: routineN = 'get_issc_env', 00599 routineP = moduleN//':'//routineN 00600 00601 LOGICAL :: failure 00602 00603 failure =.FALSE. 00604 00605 CPPrecondition(issc_env%ref_count>0,cp_failure_level,routineP,error,failure) 00606 00607 IF(PRESENT(issc_on_atom_list)) issc_on_atom_list => issc_env%issc_on_atom_list 00608 IF(PRESENT(issc_gapw_radius )) issc_gapw_radius = issc_env%issc_gapw_radius 00609 IF(PRESENT(issc_loc )) issc_loc => issc_env%issc_loc 00610 IF(PRESENT(issc )) issc => issc_env%issc 00611 IF(PRESENT(interpolate_issc )) interpolate_issc = issc_env%interpolate_issc 00612 IF(PRESENT(psi1_efg )) psi1_efg => issc_env%psi1_efg 00613 IF(PRESENT(psi1_pso )) psi1_pso => issc_env%psi1_pso 00614 IF(PRESENT(psi1_dso )) psi1_dso => issc_env%psi1_dso 00615 IF(PRESENT(psi1_fc )) psi1_fc => issc_env%psi1_fc 00616 IF(PRESENT(efg_psi0 )) efg_psi0 => issc_env%efg_psi0 00617 IF(PRESENT(pso_psi0 )) pso_psi0 => issc_env%pso_psi0 00618 IF(PRESENT(dso_psi0 )) dso_psi0 => issc_env%dso_psi0 00619 IF(PRESENT(fc_psi0 )) fc_psi0 => issc_env%fc_psi0 00620 IF(PRESENT(matrix_efg )) matrix_efg => issc_env%matrix_efg 00621 IF(PRESENT(matrix_pso )) matrix_pso => issc_env%matrix_pso 00622 IF(PRESENT(matrix_fc )) matrix_fc => issc_env%matrix_fc 00623 IF(PRESENT(matrix_dso )) matrix_dso => issc_env%matrix_dso 00624 IF(PRESENT(do_fc )) do_fc = issc_env%do_fc 00625 IF(PRESENT(do_sd )) do_sd = issc_env%do_sd 00626 IF(PRESENT(do_pso )) do_pso = issc_env%do_pso 00627 IF(PRESENT(do_dso )) do_dso = issc_env%do_dso 00628 00629 END SUBROUTINE get_issc_env 00630 00631 ! ***************************************************************************** 00632 SUBROUTINE set_current_env(current_env,jrho1_atom_set,jrho1_set,error) 00633 00634 TYPE(current_env_type) :: current_env 00635 TYPE(jrho_atom_type), DIMENSION(:), 00636 OPTIONAL, POINTER :: jrho1_atom_set 00637 TYPE(qs_rho_p_type), DIMENSION(:), 00638 OPTIONAL, POINTER :: jrho1_set 00639 TYPE(cp_error_type), INTENT(inout) :: error 00640 00641 CHARACTER(len=*), PARAMETER :: routineN = 'set_current_env', 00642 routineP = moduleN//':'//routineN 00643 00644 INTEGER :: idir 00645 LOGICAL :: failure 00646 00647 failure =.FALSE. 00648 00649 CPPrecondition(current_env%ref_count>0, cp_failure_level,routineP,error,failure) 00650 00651 IF(.NOT. failure) THEN 00652 00653 IF(PRESENT(jrho1_atom_set)) THEN 00654 IF(ASSOCIATED(current_env%jrho1_atom_set)) THEN 00655 CALL deallocate_jrho_atom_set(current_env%jrho1_atom_set,error=error) 00656 ENDIF 00657 current_env%jrho1_atom_set => jrho1_atom_set 00658 END IF 00659 00660 IF(PRESENT(jrho1_set)) THEN 00661 IF(ASSOCIATED(current_env%jrho1_set)) THEN 00662 DO idir = 1,3 00663 CALL qs_rho_release(current_env%jrho1_set(idir)%rho,error=error) 00664 END DO 00665 END IF 00666 current_env%jrho1_set => jrho1_set 00667 END IF 00668 END IF 00669 00670 END SUBROUTINE set_current_env 00671 ! ***************************************************************************** 00672 SUBROUTINE set_nmr_env(nmr_env,shift_factor,chi_factor,chi_SI2shiftppm,chi_SI2ppmcgs,& 00673 error) 00674 00675 TYPE(nmr_env_type) :: nmr_env 00676 REAL(dp), INTENT(IN), OPTIONAL :: shift_factor, chi_factor, 00677 chi_SI2shiftppm, chi_SI2ppmcgs 00678 TYPE(cp_error_type), INTENT(inout) :: error 00679 00680 CHARACTER(len=*), PARAMETER :: routineN = 'set_nmr_env', 00681 routineP = moduleN//':'//routineN 00682 00683 LOGICAL :: failure 00684 00685 failure =.FALSE. 00686 00687 CPPrecondition(nmr_env%ref_count>0, cp_failure_level,routineP,error,failure) 00688 00689 IF(PRESENT(shift_factor )) nmr_env%chi_factor = chi_factor 00690 IF(PRESENT(shift_factor )) nmr_env%chi_factor = chi_factor 00691 IF(PRESENT(chi_SI2shiftppm)) nmr_env%chi_SI2shiftppm = chi_SI2shiftppm 00692 IF(PRESENT(chi_SI2ppmcgs )) nmr_env%chi_SI2ppmcgs = chi_SI2ppmcgs 00693 00694 END SUBROUTINE set_nmr_env 00695 ! ***************************************************************************** 00696 SUBROUTINE set_issc_env(issc_env,error) 00697 00698 TYPE(issc_env_type) :: issc_env 00699 TYPE(cp_error_type), INTENT(inout) :: error 00700 00701 CHARACTER(len=*), PARAMETER :: routineN = 'set_issc_env', 00702 routineP = moduleN//':'//routineN 00703 00704 LOGICAL :: failure 00705 00706 failure =.FALSE. 00707 00708 CPPrecondition(issc_env%ref_count>0, cp_failure_level,routineP,error,failure) 00709 00710 END SUBROUTINE set_issc_env 00711 00712 ! ***************************************************************************** 00713 SUBROUTINE get_epr_env(epr_env, g_total, g_so, g_soo, nablavks_set, nablavks_atom_set, & 00714 bind_set, bind_atom_set, error) 00715 00716 TYPE(epr_env_type) :: epr_env 00717 REAL(dp), DIMENSION(:, :), OPTIONAL, 00718 POINTER :: g_total, g_so, g_soo 00719 TYPE(qs_rho_p_type), DIMENSION(:, :), 00720 OPTIONAL, POINTER :: nablavks_set 00721 TYPE(nablavks_atom_type), DIMENSION(:), 00722 OPTIONAL, POINTER :: nablavks_atom_set 00723 TYPE(qs_rho_p_type), DIMENSION(:, :), 00724 OPTIONAL, POINTER :: bind_set 00725 TYPE(rho_atom_coeff), DIMENSION(:, :), 00726 OPTIONAL, POINTER :: bind_atom_set 00727 TYPE(cp_error_type), INTENT(inout), 00728 OPTIONAL :: error 00729 00730 CHARACTER(len=*), PARAMETER :: routineN = 'get_epr_env', 00731 routineP = moduleN//':'//routineN 00732 00733 LOGICAL :: failure 00734 00735 failure =.FALSE. 00736 00737 CPPrecondition(epr_env%ref_count>0, cp_failure_level,routineP,error,failure) 00738 00739 IF(PRESENT(g_total)) g_total => epr_env%g_total 00740 IF(PRESENT(g_so)) g_so => epr_env%g_so 00741 IF(PRESENT(g_soo)) g_soo => epr_env%g_soo 00742 IF(PRESENT(nablavks_set)) nablavks_set => epr_env%nablavks_set 00743 IF(PRESENT(nablavks_atom_set)) nablavks_atom_set => epr_env%nablavks_atom_set 00744 IF(PRESENT(bind_set)) bind_set => epr_env%bind_set 00745 IF(PRESENT(bind_atom_set)) bind_atom_set => epr_env%bind_atom_set 00746 00747 END SUBROUTINE get_epr_env 00748 00749 ! ***************************************************************************** 00750 SUBROUTINE set_epr_env(epr_env,g_free_factor,g_soo_chicorr_factor,& 00751 g_soo_factor,g_so_factor,g_so_factor_gapw,& 00752 g_zke_factor,nablavks_set,nablavks_atom_set,& 00753 error) 00754 00755 TYPE(epr_env_type) :: epr_env 00756 REAL(dp), INTENT(IN), OPTIONAL :: g_free_factor, g_soo_chicorr_factor, 00757 g_soo_factor, g_so_factor, g_so_factor_gapw, g_zke_factor 00758 TYPE(qs_rho_p_type), DIMENSION(:, :), 00759 OPTIONAL, POINTER :: nablavks_set 00760 TYPE(nablavks_atom_type), DIMENSION(:), 00761 OPTIONAL, POINTER :: nablavks_atom_set 00762 TYPE(cp_error_type), INTENT(inout), 00763 OPTIONAL :: error 00764 00765 CHARACTER(len=*), PARAMETER :: routineN = 'set_epr_env', 00766 routineP = moduleN//':'//routineN 00767 00768 INTEGER :: idir, ispin 00769 LOGICAL :: failure 00770 00771 failure =.FALSE. 00772 00773 CPPrecondition(epr_env%ref_count>0, cp_failure_level,routineP,error,failure) 00774 00775 IF(PRESENT(g_free_factor)) epr_env%g_free_factor=g_free_factor 00776 IF(PRESENT(g_zke_factor)) epr_env%g_zke_factor=g_zke_factor 00777 IF(PRESENT(g_so_factor)) epr_env%g_so_factor=g_so_factor 00778 IF(PRESENT(g_so_factor_gapw)) epr_env%g_so_factor_gapw=g_so_factor_gapw 00779 IF(PRESENT(g_soo_factor)) epr_env%g_soo_factor=g_soo_factor 00780 IF(PRESENT(g_soo_chicorr_factor)) epr_env%g_soo_chicorr_factor=g_soo_chicorr_factor 00781 00782 IF(PRESENT(nablavks_set)) THEN 00783 IF(ASSOCIATED(epr_env%nablavks_set)) THEN 00784 DO ispin = 1,2 00785 DO idir = 1,3 00786 CALL qs_rho_release(epr_env%nablavks_set(idir,ispin)%rho,error=error) 00787 END DO 00788 END DO 00789 END IF 00790 epr_env%nablavks_set => nablavks_set 00791 ENDIF 00792 00793 IF(PRESENT(nablavks_atom_set)) THEN 00794 IF(ASSOCIATED(epr_env%nablavks_atom_set)) THEN 00795 CALL deallocate_nablavks_atom_set(epr_env%nablavks_atom_set,error=error) 00796 ENDIF 00797 epr_env%nablavks_atom_set => nablavks_atom_set 00798 ENDIF 00799 00800 END SUBROUTINE set_epr_env 00801 00802 ! ***************************************************************************** 00803 SUBROUTINE allocate_nablavks_atom_set(nablavks_atom_set,natom,error) 00804 00805 TYPE(nablavks_atom_type), DIMENSION(:), 00806 POINTER :: nablavks_atom_set 00807 INTEGER, INTENT(IN) :: natom 00808 TYPE(cp_error_type), INTENT(inout), 00809 OPTIONAL :: error 00810 00811 CHARACTER(len=*), PARAMETER :: routineN = 'allocate_nablavks_atom_set', 00812 routineP = moduleN//':'//routineN 00813 00814 INTEGER :: iat, istat 00815 LOGICAL :: failure 00816 00817 failure = .FALSE. 00818 00819 ALLOCATE(nablavks_atom_set(natom), STAT=istat) 00820 CPPrecondition(istat==0, cp_failure_level,routineP,error,failure) 00821 00822 DO iat = 1,natom 00823 NULLIFY(nablavks_atom_set(iat)%nablavks_vec_rad_h) 00824 NULLIFY(nablavks_atom_set(iat)%nablavks_vec_rad_s) 00825 ENDDO 00826 END SUBROUTINE allocate_nablavks_atom_set 00827 00828 ! ***************************************************************************** 00829 SUBROUTINE deallocate_nablavks_atom_set(nablavks_atom_set,error) 00830 00831 TYPE(nablavks_atom_type), DIMENSION(:), 00832 POINTER :: nablavks_atom_set 00833 TYPE(cp_error_type), INTENT(inout), 00834 OPTIONAL :: error 00835 00836 CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_nablavks_atom_set', 00837 routineP = moduleN//':'//routineN 00838 00839 INTEGER :: i, iat, idir, istat, n, natom 00840 LOGICAL :: failure 00841 00842 failure = .FALSE. 00843 00844 CPPrecondition(ASSOCIATED(nablavks_atom_set),cp_failure_level,routineP,error,failure) 00845 natom = SIZE(nablavks_atom_set) 00846 00847 DO iat = 1,natom 00848 IF(ASSOCIATED(nablavks_atom_set(iat)%nablavks_vec_rad_h)) THEN 00849 IF(ASSOCIATED(nablavks_atom_set(iat)%nablavks_vec_rad_h(1,1)%r_coef)) THEN 00850 n = SIZE(nablavks_atom_set(iat)%nablavks_vec_rad_h,2) 00851 DO i=1,n 00852 DO idir = 1,3 00853 DEALLOCATE(nablavks_atom_set(iat)%nablavks_vec_rad_h(idir,i)%r_coef,STAT=istat) 00854 CPPrecondition(istat==0, cp_failure_level,routineP,error,failure) 00855 DEALLOCATE(nablavks_atom_set(iat)%nablavks_vec_rad_s(idir,i)%r_coef,STAT=istat) 00856 CPPrecondition(istat==0, cp_failure_level,routineP,error,failure) 00857 ENDDO 00858 ENDDO 00859 ENDIF 00860 DEALLOCATE(nablavks_atom_set(iat)%nablavks_vec_rad_h,STAT=istat) 00861 CPPrecondition(istat==0, cp_failure_level,routineP,error,failure) 00862 DEALLOCATE(nablavks_atom_set(iat)%nablavks_vec_rad_s,STAT=istat) 00863 CPPrecondition(istat==0, cp_failure_level,routineP,error,failure) 00864 ENDIF 00865 ENDDO 00866 DEALLOCATE(nablavks_atom_set, STAT=istat) 00867 CPPrecondition(istat==0, cp_failure_level,routineP,error,failure) 00868 END SUBROUTINE deallocate_nablavks_atom_set 00869 00870 ! ***************************************************************************** 00871 SUBROUTINE allocate_jrho_atom_set(jrho_atom_set,natom,error) 00872 00873 TYPE(jrho_atom_type), DIMENSION(:), 00874 POINTER :: jrho_atom_set 00875 INTEGER, INTENT(IN) :: natom 00876 TYPE(cp_error_type), INTENT(inout) :: error 00877 00878 CHARACTER(len=*), PARAMETER :: routineN = 'allocate_jrho_atom_set', 00879 routineP = moduleN//':'//routineN 00880 00881 INTEGER :: iat, istat 00882 LOGICAL :: failure 00883 00884 failure = .FALSE. 00885 00886 ALLOCATE(jrho_atom_set(natom), STAT=istat) 00887 CPPrecondition(istat==0, cp_failure_level,routineP,error,failure) 00888 00889 DO iat = 1,natom 00890 NULLIFY(jrho_atom_set(iat)%cjc0_h) 00891 NULLIFY(jrho_atom_set(iat)%cjc0_s) 00892 NULLIFY(jrho_atom_set(iat)%cjc_h) 00893 NULLIFY(jrho_atom_set(iat)%cjc_s) 00894 NULLIFY(jrho_atom_set(iat)%cjc_ii_h) 00895 NULLIFY(jrho_atom_set(iat)%cjc_ii_s) 00896 NULLIFY(jrho_atom_set(iat)%cjc_iii_h) 00897 NULLIFY(jrho_atom_set(iat)%cjc_iii_s) 00898 NULLIFY(jrho_atom_set(iat)%jrho_vec_rad_h) 00899 NULLIFY(jrho_atom_set(iat)%jrho_vec_rad_s) 00900 NULLIFY(jrho_atom_set(iat)%jrho_h) 00901 NULLIFY(jrho_atom_set(iat)%jrho_s) 00902 NULLIFY(jrho_atom_set(iat)%jrho_a_h) 00903 NULLIFY(jrho_atom_set(iat)%jrho_a_s) 00904 NULLIFY(jrho_atom_set(iat)%jrho_b_h) 00905 NULLIFY(jrho_atom_set(iat)%jrho_b_s) 00906 NULLIFY(jrho_atom_set(iat)%jrho_a_h_ii) 00907 NULLIFY(jrho_atom_set(iat)%jrho_a_s_ii) 00908 NULLIFY(jrho_atom_set(iat)%jrho_b_h_ii) 00909 NULLIFY(jrho_atom_set(iat)%jrho_b_s_ii) 00910 NULLIFY(jrho_atom_set(iat)%jrho_a_h_iii) 00911 NULLIFY(jrho_atom_set(iat)%jrho_a_s_iii) 00912 NULLIFY(jrho_atom_set(iat)%jrho_b_h_iii) 00913 NULLIFY(jrho_atom_set(iat)%jrho_b_s_iii) 00914 ENDDO 00915 END SUBROUTINE allocate_jrho_atom_set 00916 00917 ! ***************************************************************************** 00918 SUBROUTINE deallocate_jrho_atom_set(jrho_atom_set,error) 00919 00920 TYPE(jrho_atom_type), DIMENSION(:), 00921 POINTER :: jrho_atom_set 00922 TYPE(cp_error_type), INTENT(inout) :: error 00923 00924 CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_jrho_atom_set', 00925 routineP = moduleN//':'//routineN 00926 00927 INTEGER :: i, iat, idir, istat, n, natom 00928 LOGICAL :: failure 00929 00930 failure = .FALSE. 00931 00932 CPPrecondition(ASSOCIATED(jrho_atom_set),cp_failure_level,routineP,error,failure) 00933 natom = SIZE(jrho_atom_set) 00934 00935 DO iat = 1,natom 00936 IF(ASSOCIATED(jrho_atom_set(iat)%cjc_h)) THEN 00937 IF(ASSOCIATED(jrho_atom_set(iat)%cjc_h(1)%r_coef)) THEN 00938 n = SIZE(jrho_atom_set(iat)%cjc_h) 00939 DO i = 1,n 00940 ! 00941 ! size = (nsotot,nsotot) replicated 00942 DEALLOCATE(jrho_atom_set(iat)%cjc0_h(i)%r_coef,& 00943 & jrho_atom_set(iat)%cjc0_s(i)%r_coef,& 00944 & jrho_atom_set(iat)%cjc_h(i)%r_coef,& 00945 & jrho_atom_set(iat)%cjc_s(i)%r_coef,& 00946 & jrho_atom_set(iat)%cjc_ii_h(i)%r_coef,& 00947 & jrho_atom_set(iat)%cjc_ii_s(i)%r_coef,& 00948 & jrho_atom_set(iat)%cjc_iii_h(i)%r_coef,& 00949 & jrho_atom_set(iat)%cjc_iii_s(i)%r_coef,& 00950 & STAT=istat) 00951 CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) 00952 END DO 00953 END IF 00954 DEALLOCATE(jrho_atom_set(iat)%cjc0_h,& 00955 & jrho_atom_set(iat)%cjc0_s,& 00956 & jrho_atom_set(iat)%cjc_h,& 00957 & jrho_atom_set(iat)%cjc_s,& 00958 & jrho_atom_set(iat)%cjc_ii_h,& 00959 & jrho_atom_set(iat)%cjc_ii_s,& 00960 & jrho_atom_set(iat)%cjc_iii_h,& 00961 & jrho_atom_set(iat)%cjc_iii_s,& 00962 & STAT=istat) 00963 CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) 00964 END IF 00965 00966 IF(ASSOCIATED(jrho_atom_set(iat)%jrho_a_h)) THEN 00967 IF(ASSOCIATED(jrho_atom_set(iat)%jrho_a_h(1)%r_coef)) THEN 00968 n = SIZE(jrho_atom_set(iat)%jrho_a_h) 00969 DO i = 1,n 00970 ! 00971 ! size = (nr,max_iso_not0) distributed 00972 DEALLOCATE(jrho_atom_set(iat)%jrho_h(i)%r_coef,& 00973 & jrho_atom_set(iat)%jrho_s(i)%r_coef,& 00974 & jrho_atom_set(iat)%jrho_a_h(i)%r_coef,& 00975 & jrho_atom_set(iat)%jrho_a_s(i)%r_coef,& 00976 & jrho_atom_set(iat)%jrho_b_h(i)%r_coef,& 00977 & jrho_atom_set(iat)%jrho_b_s(i)%r_coef,& 00978 & jrho_atom_set(iat)%jrho_a_h_ii(i)%r_coef,& 00979 & jrho_atom_set(iat)%jrho_a_s_ii(i)%r_coef,& 00980 & jrho_atom_set(iat)%jrho_b_h_ii(i)%r_coef,& 00981 & jrho_atom_set(iat)%jrho_b_s_ii(i)%r_coef,& 00982 & jrho_atom_set(iat)%jrho_a_h_iii(i)%r_coef,& 00983 & jrho_atom_set(iat)%jrho_a_s_iii(i)%r_coef,& 00984 & jrho_atom_set(iat)%jrho_b_h_iii(i)%r_coef,& 00985 & jrho_atom_set(iat)%jrho_b_s_iii(i)%r_coef,& 00986 & STAT=istat) 00987 CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) 00988 END DO 00989 END IF 00990 DEALLOCATE(jrho_atom_set(iat)%jrho_h,& 00991 & jrho_atom_set(iat)%jrho_s,& 00992 & jrho_atom_set(iat)%jrho_a_h,& 00993 & jrho_atom_set(iat)%jrho_a_s,& 00994 & jrho_atom_set(iat)%jrho_b_h,& 00995 & jrho_atom_set(iat)%jrho_b_s,& 00996 & jrho_atom_set(iat)%jrho_a_h_ii,& 00997 & jrho_atom_set(iat)%jrho_a_s_ii,& 00998 & jrho_atom_set(iat)%jrho_b_h_ii,& 00999 & jrho_atom_set(iat)%jrho_b_s_ii,& 01000 & jrho_atom_set(iat)%jrho_a_h_iii,& 01001 & jrho_atom_set(iat)%jrho_a_s_iii,& 01002 & jrho_atom_set(iat)%jrho_b_h_iii,& 01003 & jrho_atom_set(iat)%jrho_b_s_iii,& 01004 & STAT=istat) 01005 CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) 01006 END IF 01007 01008 IF(ASSOCIATED(jrho_atom_set(iat)%jrho_vec_rad_h)) THEN 01009 IF(ASSOCIATED(jrho_atom_set(iat)%jrho_vec_rad_h(1,1)%r_coef)) THEN 01010 n = SIZE(jrho_atom_set(iat)%jrho_vec_rad_h,2) 01011 DO i = 1,n 01012 DO idir = 1,3 01013 ! 01014 ! size =(nr,na) distributed 01015 DEALLOCATE(jrho_atom_set(iat)%jrho_vec_rad_h(idir,i)%r_coef,& 01016 & jrho_atom_set(iat)%jrho_vec_rad_s(idir,i)%r_coef,& 01017 & STAT=istat) 01018 CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) 01019 END DO 01020 END DO 01021 ENDIF 01022 DEALLOCATE(jrho_atom_set(iat)%jrho_vec_rad_h,& 01023 & jrho_atom_set(iat)%jrho_vec_rad_s,& 01024 & STAT=istat) 01025 CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) 01026 END IF 01027 END DO 01028 DEALLOCATE(jrho_atom_set,STAT=istat) 01029 CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) 01030 01031 END SUBROUTINE deallocate_jrho_atom_set 01032 01033 ! ***************************************************************************** 01034 SUBROUTINE allocate_jrho_atom_rad(jrho1_atom,ispin,nr,na,max_iso_not0,error) 01035 01036 TYPE(jrho_atom_type), POINTER :: jrho1_atom 01037 INTEGER, INTENT(IN) :: ispin, nr, na, max_iso_not0 01038 TYPE(cp_error_type), INTENT(inout) :: error 01039 01040 CHARACTER(len=*), PARAMETER :: routineN = 'allocate_jrho_atom_rad', 01041 routineP = moduleN//':'//routineN 01042 01043 INTEGER :: handle, idir, istat 01044 LOGICAL :: failure 01045 01046 CALL timeset(routineN,handle) 01047 01048 failure = .FALSE. 01049 01050 CPPrecondition(ASSOCIATED(jrho1_atom),cp_failure_level,routineP,error,failure) 01051 01052 IF(.NOT.failure) THEN 01053 01054 DO idir = 1,3 01055 ALLOCATE(jrho1_atom%jrho_vec_rad_h(idir,ispin)%r_coef(nr,na),& 01056 & jrho1_atom%jrho_vec_rad_s(idir,ispin)%r_coef(nr,na),& 01057 & STAT=istat) 01058 CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) 01059 jrho1_atom%jrho_vec_rad_h(idir,ispin)%r_coef = 0.0_dp 01060 jrho1_atom%jrho_vec_rad_s(idir,ispin)%r_coef = 0.0_dp 01061 ENDDO 01062 01063 ALLOCATE(jrho1_atom%jrho_h(ispin)%r_coef(nr,max_iso_not0),& 01064 & jrho1_atom%jrho_s(ispin)%r_coef(nr,max_iso_not0),& 01065 & jrho1_atom%jrho_a_h(ispin)%r_coef(nr,max_iso_not0),& 01066 & jrho1_atom%jrho_a_s(ispin)%r_coef(nr,max_iso_not0),& 01067 & jrho1_atom%jrho_b_h(ispin)%r_coef(nr,max_iso_not0),& 01068 & jrho1_atom%jrho_b_s(ispin)%r_coef(nr,max_iso_not0),& 01069 & jrho1_atom%jrho_a_h_ii(ispin)%r_coef(nr,max_iso_not0),& 01070 & jrho1_atom%jrho_a_s_ii(ispin)%r_coef(nr,max_iso_not0),& 01071 & jrho1_atom%jrho_b_h_ii(ispin)%r_coef(nr,max_iso_not0),& 01072 & jrho1_atom%jrho_b_s_ii(ispin)%r_coef(nr,max_iso_not0),& 01073 & jrho1_atom%jrho_a_h_iii(ispin)%r_coef(nr,max_iso_not0),& 01074 & jrho1_atom%jrho_a_s_iii(ispin)%r_coef(nr,max_iso_not0),& 01075 & jrho1_atom%jrho_b_h_iii(ispin)%r_coef(nr,max_iso_not0),& 01076 & jrho1_atom%jrho_b_s_iii(ispin)%r_coef(nr,max_iso_not0),& 01077 & STAT=istat) 01078 CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) 01079 ! 01080 jrho1_atom%jrho_h(ispin)%r_coef = 0.0_dp 01081 jrho1_atom%jrho_s(ispin)%r_coef = 0.0_dp 01082 jrho1_atom%jrho_a_h(ispin)%r_coef = 0.0_dp 01083 jrho1_atom%jrho_a_s(ispin)%r_coef = 0.0_dp 01084 jrho1_atom%jrho_b_h(ispin)%r_coef = 0.0_dp 01085 jrho1_atom%jrho_b_s(ispin)%r_coef = 0.0_dp 01086 jrho1_atom%jrho_a_h_ii(ispin)%r_coef = 0.0_dp 01087 jrho1_atom%jrho_a_s_ii(ispin)%r_coef = 0.0_dp 01088 jrho1_atom%jrho_b_h_ii(ispin)%r_coef = 0.0_dp 01089 jrho1_atom%jrho_b_s_ii(ispin)%r_coef = 0.0_dp 01090 jrho1_atom%jrho_a_h_iii(ispin)%r_coef = 0.0_dp 01091 jrho1_atom%jrho_a_s_iii(ispin)%r_coef = 0.0_dp 01092 jrho1_atom%jrho_b_h_iii(ispin)%r_coef = 0.0_dp 01093 jrho1_atom%jrho_b_s_iii(ispin)%r_coef = 0.0_dp 01094 END IF 01095 CALL timestop(handle) 01096 01097 END SUBROUTINE allocate_jrho_atom_rad 01098 01099 ! ***************************************************************************** 01100 SUBROUTINE set2zero_jrho_atom_rad(jrho1_atom,ispin,error) 01101 ! 01102 TYPE(jrho_atom_type), POINTER :: jrho1_atom 01103 INTEGER, INTENT(IN) :: ispin 01104 TYPE(cp_error_type), INTENT(inout) :: error 01105 01106 CHARACTER(len=*), PARAMETER :: routineN = 'set2zero_jrho_atom_rad', 01107 routineP = moduleN//':'//routineN 01108 01109 LOGICAL :: failure 01110 01111 failure = .FALSE. 01112 ! 01113 CPPrecondition(ASSOCIATED(jrho1_atom),cp_failure_level,routineP,error,failure) 01114 ! 01115 IF(.NOT.failure) THEN 01116 jrho1_atom%jrho_h(ispin)%r_coef = 0.0_dp 01117 jrho1_atom%jrho_s(ispin)%r_coef = 0.0_dp 01118 ! 01119 jrho1_atom%jrho_a_h(ispin)%r_coef = 0.0_dp 01120 jrho1_atom%jrho_a_s(ispin)%r_coef = 0.0_dp 01121 jrho1_atom%jrho_b_h(ispin)%r_coef = 0.0_dp 01122 jrho1_atom%jrho_b_s(ispin)%r_coef = 0.0_dp 01123 ! 01124 jrho1_atom%jrho_a_h_ii(ispin)%r_coef = 0.0_dp 01125 jrho1_atom%jrho_a_s_ii(ispin)%r_coef = 0.0_dp 01126 jrho1_atom%jrho_b_h_ii(ispin)%r_coef = 0.0_dp 01127 jrho1_atom%jrho_b_s_ii(ispin)%r_coef = 0.0_dp 01128 ! 01129 jrho1_atom%jrho_a_h_iii(ispin)%r_coef = 0.0_dp 01130 jrho1_atom%jrho_a_s_iii(ispin)%r_coef = 0.0_dp 01131 jrho1_atom%jrho_b_h_iii(ispin)%r_coef = 0.0_dp 01132 jrho1_atom%jrho_b_s_iii(ispin)%r_coef = 0.0_dp 01133 ! 01134 ENDIF 01135 END SUBROUTINE set2zero_jrho_atom_rad 01136 01137 ! ***************************************************************************** 01138 01139 SUBROUTINE allocate_jrho_coeff(jrho1_atom_set,iatom,nsotot,error) 01140 01141 TYPE(jrho_atom_type), DIMENSION(:), 01142 POINTER :: jrho1_atom_set 01143 INTEGER, INTENT(IN) :: iatom, nsotot 01144 TYPE(cp_error_type), INTENT(inout) :: error 01145 01146 CHARACTER(len=*), PARAMETER :: routineN = 'allocate_jrho_coeff', 01147 routineP = moduleN//':'//routineN 01148 01149 INTEGER :: handle, i, istat 01150 LOGICAL :: failure 01151 01152 CALL timeset(routineN,handle) 01153 failure = .FALSE. 01154 CPPrecondition(ASSOCIATED(jrho1_atom_set),cp_failure_level,routineP,error,failure) 01155 IF(.NOT.failure) THEN 01156 DO i = 1,SIZE(jrho1_atom_set(iatom)%cjc0_h,1) 01157 ALLOCATE(jrho1_atom_set(iatom)%cjc0_h(i)%r_coef(nsotot,nsotot),& 01158 & jrho1_atom_set(iatom)%cjc0_s(i)%r_coef(nsotot,nsotot),& 01159 & jrho1_atom_set(iatom)%cjc_h(i)%r_coef(nsotot,nsotot),& 01160 & jrho1_atom_set(iatom)%cjc_s(i)%r_coef(nsotot,nsotot),& 01161 & jrho1_atom_set(iatom)%cjc_ii_h(i)%r_coef(nsotot,nsotot),& 01162 & jrho1_atom_set(iatom)%cjc_ii_s(i)%r_coef(nsotot,nsotot),& 01163 & jrho1_atom_set(iatom)%cjc_iii_h(i)%r_coef(nsotot,nsotot),& 01164 & jrho1_atom_set(iatom)%cjc_iii_s(i)%r_coef(nsotot,nsotot),& 01165 & STAT=istat) 01166 CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) 01167 jrho1_atom_set(iatom)%cjc0_h(i)%r_coef = 0.0_dp 01168 jrho1_atom_set(iatom)%cjc0_s(i)%r_coef = 0.0_dp 01169 jrho1_atom_set(iatom)%cjc_h(i)%r_coef = 0.0_dp 01170 jrho1_atom_set(iatom)%cjc_s(i)%r_coef = 0.0_dp 01171 jrho1_atom_set(iatom)%cjc_ii_h(i)%r_coef = 0.0_dp 01172 jrho1_atom_set(iatom)%cjc_ii_s(i)%r_coef = 0.0_dp 01173 jrho1_atom_set(iatom)%cjc_iii_h(i)%r_coef = 0.0_dp 01174 jrho1_atom_set(iatom)%cjc_iii_s(i)%r_coef = 0.0_dp 01175 ENDDO 01176 ENDIF 01177 CALL timestop(handle) 01178 END SUBROUTINE allocate_jrho_coeff 01179 01180 ! ***************************************************************************** 01181 01182 SUBROUTINE deallocate_jrho_coeff(jrho1_atom_set,iatom,error) 01183 01184 TYPE(jrho_atom_type), DIMENSION(:), 01185 POINTER :: jrho1_atom_set 01186 INTEGER, INTENT(IN) :: iatom 01187 TYPE(cp_error_type), INTENT(inout) :: error 01188 01189 CHARACTER(len=*), PARAMETER :: routineN = 'deallocate_jrho_coeff', 01190 routineP = moduleN//':'//routineN 01191 01192 INTEGER :: handle, i, istat 01193 LOGICAL :: failure 01194 01195 CALL timeset(routineN,handle) 01196 failure = .FALSE. 01197 CPPrecondition(ASSOCIATED(jrho1_atom_set),cp_failure_level,routineP,error,failure) 01198 IF(.NOT.failure) THEN 01199 DO i = 1,SIZE(jrho1_atom_set(iatom)%cjc0_h,1) 01200 DEALLOCATE(jrho1_atom_set(iatom)%cjc0_h(i)%r_coef,& 01201 & jrho1_atom_set(iatom)%cjc0_s(i)%r_coef,& 01202 & jrho1_atom_set(iatom)%cjc_h(i)%r_coef,& 01203 & jrho1_atom_set(iatom)%cjc_s(i)%r_coef,& 01204 & jrho1_atom_set(iatom)%cjc_ii_h(i)%r_coef,& 01205 & jrho1_atom_set(iatom)%cjc_ii_s(i)%r_coef,& 01206 & jrho1_atom_set(iatom)%cjc_iii_h(i)%r_coef,& 01207 & jrho1_atom_set(iatom)%cjc_iii_s(i)%r_coef,& 01208 & STAT=istat) 01209 CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) 01210 ENDDO 01211 ENDIF 01212 CALL timestop(handle) 01213 END SUBROUTINE deallocate_jrho_coeff 01214 01215 ! ***************************************************************************** 01216 01217 SUBROUTINE get_jrho_atom(jrho1_atom_set,iatom,cjc_h,cjc_s,cjc_ii_h,cjc_ii_s,& 01218 cjc_iii_h,cjc_iii_s,jrho_vec_rad_h,jrho_vec_rad_s,error) 01219 01220 TYPE(jrho_atom_type), DIMENSION(:), 01221 POINTER :: jrho1_atom_set 01222 INTEGER, INTENT(IN) :: iatom 01223 TYPE(rho_atom_coeff), DIMENSION(:), 01224 OPTIONAL, POINTER :: cjc_h, cjc_s, cjc_ii_h, 01225 cjc_ii_s, cjc_iii_h, cjc_iii_s 01226 TYPE(rho_atom_coeff), DIMENSION(:, :), 01227 OPTIONAL, POINTER :: jrho_vec_rad_h, jrho_vec_rad_s 01228 TYPE(cp_error_type), INTENT(inout) :: error 01229 01230 CHARACTER(len=*), PARAMETER :: routineN = 'get_jrho_atom', 01231 routineP = moduleN//':'//routineN 01232 01233 LOGICAL :: failure 01234 01235 failure = .FALSE. 01236 01237 CPPrecondition(ASSOCIATED(jrho1_atom_set),cp_failure_level,routineP,error,failure) 01238 01239 IF(.NOT.failure) THEN 01240 IF(PRESENT(cjc_h )) cjc_h => jrho1_atom_set(iatom)%cjc_h 01241 IF(PRESENT(cjc_s )) cjc_s => jrho1_atom_set(iatom)%cjc_s 01242 IF(PRESENT(cjc_ii_h )) cjc_ii_h => jrho1_atom_set(iatom)%cjc_ii_h 01243 IF(PRESENT(cjc_ii_s )) cjc_ii_s => jrho1_atom_set(iatom)%cjc_ii_s 01244 IF(PRESENT(cjc_iii_h )) cjc_iii_h => jrho1_atom_set(iatom)%cjc_iii_h 01245 IF(PRESENT(cjc_iii_s )) cjc_iii_s => jrho1_atom_set(iatom)%cjc_iii_s 01246 IF(PRESENT(jrho_vec_rad_h)) jrho_vec_rad_h => jrho1_atom_set(iatom)%jrho_vec_rad_h 01247 IF(PRESENT(jrho_vec_rad_s)) jrho_vec_rad_s => jrho1_atom_set(iatom)%jrho_vec_rad_s 01248 ENDIF 01249 01250 END SUBROUTINE get_jrho_atom 01251 01252 ! ***************************************************************************** 01253 SUBROUTINE init_jrho_atom_set(jrho1_atom_set,atomic_kind_set,nspins,error) 01254 TYPE(jrho_atom_type), DIMENSION(:), 01255 POINTER :: jrho1_atom_set 01256 TYPE(atomic_kind_type), DIMENSION(:), 01257 POINTER :: atomic_kind_set 01258 INTEGER, INTENT(IN) :: nspins 01259 TYPE(cp_error_type), INTENT(inout) :: error 01260 01261 CHARACTER(len=*), PARAMETER :: routineN = 'init_jrho_atom_set', 01262 routineP = moduleN//':'//routineN 01263 01264 INTEGER :: handle, iat, iatom, idir, 01265 ikind, ispin, istat, nat, 01266 natom, nkind 01267 INTEGER, DIMENSION(:), POINTER :: atom_list 01268 LOGICAL :: failure 01269 TYPE(atomic_kind_type), POINTER :: atomic_kind 01270 01271 CALL timeset(routineN,handle) 01272 01273 failure = .FALSE. 01274 01275 CPPrecondition(ASSOCIATED(atomic_kind_set),cp_failure_level,routineP,error,failure) 01276 01277 IF(ASSOCIATED(jrho1_atom_set)) THEN 01278 CALL deallocate_jrho_atom_set(jrho1_atom_set,error=error) 01279 END IF 01280 01281 CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,& 01282 natom = natom) 01283 01284 CALL allocate_jrho_atom_set(jrho1_atom_set,natom,error=error) 01285 01286 nkind = SIZE(atomic_kind_set) 01287 01288 DO ikind = 1,nkind 01289 01290 atomic_kind => atomic_kind_set(ikind) 01291 CALL get_atomic_kind(atomic_kind=atomic_kind,& 01292 atom_list=atom_list,natom=nat) 01293 01294 DO iat = 1,nat 01295 iatom = atom_list(iat) 01296 01297 !*** allocate the radial density for each LM,for each atom *** 01298 ALLOCATE(jrho1_atom_set(iatom)%jrho_vec_rad_h(3,nspins),& 01299 & jrho1_atom_set(iatom)%jrho_vec_rad_s(3,nspins),& 01300 & jrho1_atom_set(iatom)%jrho_h(nspins),& 01301 & jrho1_atom_set(iatom)%jrho_s(nspins),& 01302 & jrho1_atom_set(iatom)%jrho_a_h(nspins),& 01303 & jrho1_atom_set(iatom)%jrho_a_s(nspins),& 01304 & jrho1_atom_set(iatom)%jrho_b_h(nspins),& 01305 & jrho1_atom_set(iatom)%jrho_b_s(nspins),& 01306 & jrho1_atom_set(iatom)%jrho_a_h_ii(nspins),& 01307 & jrho1_atom_set(iatom)%jrho_a_s_ii(nspins),& 01308 & jrho1_atom_set(iatom)%jrho_b_s_ii(nspins),& 01309 & jrho1_atom_set(iatom)%jrho_b_h_ii(nspins),& 01310 & jrho1_atom_set(iatom)%jrho_a_h_iii(nspins),& 01311 & jrho1_atom_set(iatom)%jrho_a_s_iii(nspins),& 01312 & jrho1_atom_set(iatom)%jrho_b_s_iii(nspins),& 01313 & jrho1_atom_set(iatom)%jrho_b_h_iii(nspins),& 01314 & jrho1_atom_set(iatom)%cjc0_h(nspins),& 01315 & jrho1_atom_set(iatom)%cjc0_s(nspins),& 01316 & jrho1_atom_set(iatom)%cjc_h(nspins),& 01317 & jrho1_atom_set(iatom)%cjc_s(nspins),& 01318 & jrho1_atom_set(iatom)%cjc_ii_h(nspins),& 01319 & jrho1_atom_set(iatom)%cjc_ii_s(nspins),& 01320 & jrho1_atom_set(iatom)%cjc_iii_h(nspins),& 01321 & jrho1_atom_set(iatom)%cjc_iii_s(nspins),& 01322 & STAT=istat) 01323 CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) 01324 01325 DO ispin = 1,nspins 01326 DO idir = 1,3 01327 NULLIFY(jrho1_atom_set(iatom)%jrho_vec_rad_h(idir,ispin)%r_coef) 01328 NULLIFY(jrho1_atom_set(iatom)%jrho_vec_rad_s(idir,ispin)%r_coef) 01329 END DO 01330 NULLIFY(jrho1_atom_set(iatom)%jrho_h(ispin)%r_coef) 01331 NULLIFY(jrho1_atom_set(iatom)%jrho_s(ispin)%r_coef) 01332 NULLIFY(jrho1_atom_set(iatom)%jrho_a_h(ispin)%r_coef) 01333 NULLIFY(jrho1_atom_set(iatom)%jrho_a_s(ispin)%r_coef) 01334 NULLIFY(jrho1_atom_set(iatom)%jrho_b_h(ispin)%r_coef) 01335 NULLIFY(jrho1_atom_set(iatom)%jrho_b_s(ispin)%r_coef) 01336 NULLIFY(jrho1_atom_set(iatom)%jrho_a_h_ii(ispin)%r_coef) 01337 NULLIFY(jrho1_atom_set(iatom)%jrho_a_s_ii(ispin)%r_coef) 01338 NULLIFY(jrho1_atom_set(iatom)%jrho_b_h_ii(ispin)%r_coef) 01339 NULLIFY(jrho1_atom_set(iatom)%jrho_b_s_ii(ispin)%r_coef) 01340 NULLIFY(jrho1_atom_set(iatom)%jrho_a_h_iii(ispin)%r_coef) 01341 NULLIFY(jrho1_atom_set(iatom)%jrho_a_s_iii(ispin)%r_coef) 01342 NULLIFY(jrho1_atom_set(iatom)%jrho_b_h_iii(ispin)%r_coef) 01343 NULLIFY(jrho1_atom_set(iatom)%jrho_b_s_iii(ispin)%r_coef) 01344 NULLIFY(jrho1_atom_set(iatom)%cjc0_h(ispin)%r_coef) 01345 NULLIFY(jrho1_atom_set(iatom)%cjc0_s(ispin)%r_coef) 01346 NULLIFY(jrho1_atom_set(iatom)%cjc_h(ispin)%r_coef) 01347 NULLIFY(jrho1_atom_set(iatom)%cjc_s(ispin)%r_coef) 01348 NULLIFY(jrho1_atom_set(iatom)%cjc_ii_h(ispin)%r_coef) 01349 NULLIFY(jrho1_atom_set(iatom)%cjc_ii_s(ispin)%r_coef) 01350 NULLIFY(jrho1_atom_set(iatom)%cjc_iii_h(ispin)%r_coef) 01351 NULLIFY(jrho1_atom_set(iatom)%cjc_iii_s(ispin)%r_coef) 01352 01353 ENDDO ! ispin 01354 01355 END DO ! iat 01356 01357 END DO ! ikind 01358 01359 CALL timestop(handle) 01360 01361 END SUBROUTINE init_jrho_atom_set 01362 01363 ! ***************************************************************************** 01364 SUBROUTINE init_nablavks_atom_set(nablavks_atom_set,atomic_kind_set,nspins,error) 01365 01366 TYPE(nablavks_atom_type), DIMENSION(:), 01367 POINTER :: nablavks_atom_set 01368 TYPE(atomic_kind_type), DIMENSION(:), 01369 POINTER :: atomic_kind_set 01370 INTEGER, INTENT(IN) :: nspins 01371 TYPE(cp_error_type), INTENT(inout), 01372 OPTIONAL :: error 01373 01374 CHARACTER(len=*), PARAMETER :: routineN = 'init_nablavks_atom_set', 01375 routineP = moduleN//':'//routineN 01376 01377 INTEGER :: handle, iat, iatom, idir, ikind, ispin, istat, max_iso_not0, 01378 maxso, na, nat, natom, nkind, nr, nset, nsotot 01379 INTEGER, DIMENSION(:), POINTER :: atom_list 01380 LOGICAL :: failure 01381 TYPE(atomic_kind_type), POINTER :: atomic_kind 01382 TYPE(grid_atom_type), POINTER :: grid_atom 01383 TYPE(gto_basis_set_type), POINTER :: orb_basis_set 01384 TYPE(harmonics_atom_type), POINTER :: harmonics 01385 01386 CALL timeset(routineN,handle) 01387 01388 failure = .FALSE. 01389 01390 CPPrecondition(ASSOCIATED(atomic_kind_set),cp_failure_level,routineP,error,failure) 01391 01392 IF(ASSOCIATED(nablavks_atom_set)) THEN 01393 CALL deallocate_nablavks_atom_set(nablavks_atom_set,error=error) 01394 END IF 01395 01396 CALL get_atomic_kind_set(atomic_kind_set=atomic_kind_set,& 01397 natom = natom) 01398 01399 CALL allocate_nablavks_atom_set(nablavks_atom_set,natom,error=error) 01400 01401 nkind = SIZE(atomic_kind_set) 01402 01403 DO ikind = 1,nkind 01404 01405 atomic_kind => atomic_kind_set(ikind) 01406 CALL get_atomic_kind(atomic_kind=atomic_kind,& 01407 orb_basis_set=orb_basis_set, & 01408 atom_list=atom_list,natom=nat, & 01409 harmonics=harmonics,& 01410 grid_atom=grid_atom) 01411 01412 na = grid_atom%ng_sphere 01413 nr = grid_atom%nr 01414 01415 CALL get_gto_basis_set(gto_basis_set=orb_basis_set, & 01416 maxso=maxso, nset=nset) 01417 nsotot = maxso * nset 01418 max_iso_not0 = harmonics%max_iso_not0 01419 DO iat = 1,nat 01420 iatom = atom_list(iat) 01421 !*** allocate the radial density for each LM,for each atom *** 01422 01423 ALLOCATE (nablavks_atom_set(iatom)%nablavks_vec_rad_h(3,nspins),STAT=istat) 01424 CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) 01425 ALLOCATE (nablavks_atom_set(iatom)%nablavks_vec_rad_s(3,nspins),STAT=istat) 01426 CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) 01427 DO ispin = 1,nspins 01428 DO idir = 1,3 01429 NULLIFY(nablavks_atom_set(iatom)%nablavks_vec_rad_h(idir,ispin)%r_coef) 01430 NULLIFY(nablavks_atom_set(iatom)%nablavks_vec_rad_s(idir,ispin)%r_coef) 01431 ALLOCATE(nablavks_atom_set(iatom)%nablavks_vec_rad_h(idir,ispin)%r_coef(nr,na),STAT=istat) 01432 CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) 01433 ALLOCATE(nablavks_atom_set(iatom)%nablavks_vec_rad_s(idir,ispin)%r_coef(nr,na),STAT=istat) 01434 CPPrecondition(istat==0,cp_failure_level,routineP,error,failure) 01435 END DO 01436 END DO ! ispin 01437 END DO ! iat 01438 01439 END DO ! ikind 01440 01441 CALL timestop(handle) 01442 01443 END SUBROUTINE init_nablavks_atom_set 01444 01445 END MODULE qs_linres_types 01446
1.7.3