|
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 ! ***************************************************************************** 00013 MODULE qs_rho_types 00014 USE cp_dbcsr_operations, ONLY: cp_dbcsr_deallocate_matrix_set 00015 USE cp_dbcsr_types, ONLY: cp_dbcsr_p_type 00016 USE f77_blas 00017 USE kinds, ONLY: dp 00018 USE pw_types, ONLY: pw_p_type,& 00019 pw_release 00020 #include "cp_common_uses.h" 00021 00022 IMPLICIT NONE 00023 PRIVATE 00024 00025 LOGICAL, PRIVATE, PARAMETER :: debug_this_module=.TRUE. 00026 CHARACTER(len=*), PARAMETER, PRIVATE :: moduleN = 'qs_rho_types' 00027 00028 PUBLIC :: qs_rho_p_type, qs_rho_type 00029 PUBLIC :: qs_rho_retain, qs_rho_release, qs_rho_did_change,& 00030 qs_rho_get 00031 00032 ! ***************************************************************************** 00055 TYPE qs_rho_type 00056 TYPE(cp_dbcsr_p_type), DIMENSION(:), POINTER :: rho_ao 00057 TYPE(pw_p_type), DIMENSION(:), POINTER :: rho_g, rho_r 00058 TYPE(pw_p_type), DIMENSION(:), POINTER :: drho_g, drho_r 00059 TYPE(pw_p_type), DIMENSION(:), POINTER :: tau_g, tau_r 00060 LOGICAL :: rho_g_valid, 00061 rho_r_valid, 00062 drho_r_valid, 00063 drho_g_valid, 00064 tau_r_valid, 00065 tau_g_valid, 00066 soft_valid 00067 INTEGER :: ref_count, 00068 id_nr, 00069 rebuild_each 00070 REAL(KIND = dp), DIMENSION(:), POINTER :: tot_rho_r, tot_rho_g 00071 END TYPE qs_rho_type 00072 00073 ! ***************************************************************************** 00074 TYPE qs_rho_p_type 00075 TYPE(qs_rho_type), POINTER :: rho 00076 END TYPE qs_rho_p_type 00077 00078 CONTAINS 00079 00080 ! ***************************************************************************** 00090 SUBROUTINE qs_rho_retain(rho_struct,error) 00091 TYPE(qs_rho_type), POINTER :: rho_struct 00092 TYPE(cp_error_type), INTENT(inout) :: error 00093 00094 CHARACTER(len=*), PARAMETER :: routineN = 'qs_rho_retain', 00095 routineP = moduleN//':'//routineN 00096 00097 LOGICAL :: failure 00098 00099 failure=.FALSE. 00100 00101 CPPrecondition(ASSOCIATED(rho_struct),cp_failure_level,routineP,error,failure) 00102 IF (.NOT.failure) THEN 00103 CPPrecondition(rho_struct%ref_count>0,cp_failure_level,routineP,error,failure) 00104 rho_struct%ref_count=rho_struct%ref_count+1 00105 END IF 00106 END SUBROUTINE qs_rho_retain 00107 00108 ! ***************************************************************************** 00119 SUBROUTINE qs_rho_release(rho_struct,error) 00120 TYPE(qs_rho_type), POINTER :: rho_struct 00121 TYPE(cp_error_type), INTENT(inout) :: error 00122 00123 CHARACTER(len=*), PARAMETER :: routineN = 'qs_rho_release', 00124 routineP = moduleN//':'//routineN 00125 00126 INTEGER :: i, stat 00127 LOGICAL :: failure 00128 00129 failure=.FALSE. 00130 00131 IF (ASSOCIATED(rho_struct)) THEN 00132 CPPrecondition(rho_struct%ref_count>0,cp_failure_level,routineP,error,failure) 00133 rho_struct%ref_count=rho_struct%ref_count-1 00134 IF (rho_struct%ref_count<1) THEN 00135 IF (ASSOCIATED(rho_struct%rho_ao)) THEN 00136 IF(rho_struct%soft_valid) THEN 00137 NULLIFY(rho_struct%rho_ao) 00138 ELSE 00139 CALL cp_dbcsr_deallocate_matrix_set(rho_struct%rho_ao,error=error) 00140 ENDIF 00141 END IF 00142 IF (ASSOCIATED(rho_struct%rho_r)) THEN 00143 DO i=1,SIZE(rho_struct%rho_r) 00144 CALL pw_release(rho_struct%rho_r(i)%pw,error=error) 00145 END DO 00146 DEALLOCATE(rho_struct%rho_r,stat=stat) 00147 CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) 00148 END IF 00149 IF (ASSOCIATED(rho_struct%drho_r)) THEN 00150 DO i=1,SIZE(rho_struct%drho_r) 00151 CALL pw_release(rho_struct%drho_r(i)%pw,error=error) 00152 END DO 00153 DEALLOCATE(rho_struct%drho_r,stat=stat) 00154 CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) 00155 END IF 00156 IF (ASSOCIATED(rho_struct%drho_g)) THEN 00157 DO i=1,SIZE(rho_struct%drho_g) 00158 CALL pw_release(rho_struct%drho_g(i)%pw,error=error) 00159 END DO 00160 DEALLOCATE(rho_struct%drho_g,stat=stat) 00161 CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) 00162 END IF 00163 IF (ASSOCIATED(rho_struct%tau_r)) THEN 00164 DO i=1,SIZE(rho_struct%tau_r) 00165 CALL pw_release(rho_struct%tau_r(i)%pw,error=error) 00166 END DO 00167 DEALLOCATE(rho_struct%tau_r,stat=stat) 00168 CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) 00169 END IF 00170 IF (ASSOCIATED(rho_struct%rho_g)) THEN 00171 DO i=1,SIZE(rho_struct%rho_g) 00172 CALL pw_release(rho_struct%rho_g(i)%pw,error=error) 00173 END DO 00174 DEALLOCATE(rho_struct%rho_g,stat=stat) 00175 CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) 00176 END IF 00177 IF (ASSOCIATED(rho_struct%tau_g)) THEN 00178 DO i=1,SIZE(rho_struct%tau_g) 00179 CALL pw_release(rho_struct%tau_g(i)%pw,error=error) 00180 END DO 00181 DEALLOCATE(rho_struct%tau_g,stat=stat) 00182 CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) 00183 END IF 00184 IF (ASSOCIATED(rho_struct%tot_rho_r)) THEN 00185 DEALLOCATE(rho_struct%tot_rho_r,stat=stat) 00186 CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) 00187 ENDIF 00188 IF (ASSOCIATED(rho_struct%tot_rho_g)) THEN 00189 DEALLOCATE(rho_struct%tot_rho_g,stat=stat) 00190 CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) 00191 ENDIF 00192 DEALLOCATE(rho_struct,stat=stat) 00193 CPPostcondition(stat==0,cp_warning_level,routineP,error,failure) 00194 END IF 00195 END IF 00196 NULLIFY(rho_struct) 00197 END SUBROUTINE qs_rho_release 00198 00199 ! ***************************************************************************** 00211 SUBROUTINE qs_rho_did_change(rho_struct, rho_r_valid, drho_r_valid, tau_r_valid,& 00212 rho_g_valid, drho_g_valid, tau_g_valid, error) 00213 TYPE(qs_rho_type), POINTER :: rho_struct 00214 LOGICAL, INTENT(in), OPTIONAL :: rho_r_valid, drho_r_valid, 00215 tau_r_valid, rho_g_valid, 00216 drho_g_valid, tau_g_valid 00217 TYPE(cp_error_type), INTENT(inout) :: error 00218 00219 CHARACTER(len=*), PARAMETER :: routineN = 'qs_rho_did_change', 00220 routineP = moduleN//':'//routineN 00221 00222 LOGICAL :: failure 00223 00224 failure=.FALSE. 00225 00226 CPPrecondition(ASSOCIATED(rho_struct),cp_failure_level,routineP,error,failure) 00227 CPPrecondition(rho_struct%ref_count>0,cp_failure_level,routineP,error,failure) 00228 IF (.NOT. failure) THEN 00229 IF (PRESENT(rho_r_valid)) rho_struct%rho_r_valid=rho_r_valid 00230 IF (PRESENT(rho_g_valid)) rho_struct%rho_g_valid=rho_g_valid 00231 IF (PRESENT(drho_r_valid)) rho_struct%drho_r_valid=drho_r_valid 00232 IF (PRESENT(drho_g_valid)) rho_struct%drho_g_valid=drho_g_valid 00233 IF (PRESENT(tau_r_valid)) rho_struct%tau_r_valid=tau_r_valid 00234 IF (PRESENT(tau_g_valid)) rho_struct%tau_g_valid=tau_g_valid 00235 END IF 00236 END SUBROUTINE qs_rho_did_change 00237 00238 ! ***************************************************************************** 00248 SUBROUTINE qs_rho_get(rho_struct, rho_ao, rho_r, drho_r, rho_g, drho_g, tau_r, tau_g, & 00249 rho_r_valid, drho_r_valid, rho_g_valid, drho_g_valid, tau_r_valid, tau_g_valid, & 00250 rebuild_each, tot_rho_r, soft_valid, error) 00251 TYPE(qs_rho_type), POINTER :: rho_struct 00252 TYPE(cp_dbcsr_p_type), DIMENSION(:), 00253 OPTIONAL, POINTER :: rho_ao 00254 TYPE(pw_p_type), DIMENSION(:), 00255 OPTIONAL, POINTER :: rho_r, drho_r, rho_g, drho_g, 00256 tau_r, tau_g 00257 LOGICAL, INTENT(out), OPTIONAL :: rho_r_valid, drho_r_valid, 00258 rho_g_valid, drho_g_valid, 00259 tau_r_valid, tau_g_valid 00260 INTEGER, INTENT(out), OPTIONAL :: rebuild_each 00261 REAL(KIND=dp), DIMENSION(:), OPTIONAL, 00262 POINTER :: tot_rho_r 00263 LOGICAL, INTENT(out), OPTIONAL :: soft_valid 00264 TYPE(cp_error_type), INTENT(inout) :: error 00265 00266 CHARACTER(len=*), PARAMETER :: routineN = 'qs_rho_get', 00267 routineP = moduleN//':'//routineN 00268 00269 LOGICAL :: failure 00270 00271 failure=.FALSE. 00272 00273 CPPrecondition(ASSOCIATED(rho_struct),cp_failure_level,routineP,error,failure) 00274 CPPrecondition(rho_struct%ref_count>0,cp_failure_level,routineP,error,failure) 00275 IF (.NOT. failure) THEN 00276 IF (PRESENT(rho_ao)) THEN 00277 rho_ao => rho_struct%rho_ao 00278 END IF 00279 IF (PRESENT(rho_r)) THEN 00280 IF (PRESENT(rho_r_valid).or.rho_struct%rho_r_valid) THEN 00281 rho_r => rho_struct%rho_r 00282 ELSE 00283 CALL cp_unimplemented_error(routineP,"to do",error=error) 00284 NULLIFY(rho_r) 00285 END IF 00286 END IF 00287 IF (PRESENT(drho_r)) THEN 00288 IF (PRESENT(drho_r_valid).or.rho_struct%drho_r_valid) THEN 00289 drho_r => rho_struct%drho_r 00290 ELSE 00291 CALL cp_unimplemented_error(routineP,"to do",error=error) 00292 NULLIFY(drho_r) 00293 END IF 00294 END IF 00295 IF (PRESENT(rho_g)) THEN 00296 IF (PRESENT(rho_g_valid).or.rho_struct%rho_g_valid) THEN 00297 rho_g => rho_struct%rho_g 00298 ELSE 00299 CALL cp_unimplemented_error(routineP,"to do",error=error) 00300 NULLIFY(rho_g) 00301 END IF 00302 END IF 00303 IF (PRESENT(drho_g)) THEN 00304 IF (PRESENT(drho_g_valid).or.rho_struct%drho_g_valid) THEN 00305 drho_g => rho_struct%drho_g 00306 ELSE 00307 CALL cp_unimplemented_error(routineP,"to do",error=error) 00308 NULLIFY(drho_g) 00309 END IF 00310 END IF 00311 IF (PRESENT(tau_r)) THEN 00312 IF (PRESENT(tau_r_valid).or.rho_struct%tau_r_valid) THEN 00313 tau_r => rho_struct%tau_r 00314 ELSE 00315 CALL cp_unimplemented_error(routineP,"to do",error=error) 00316 NULLIFY(tau_r) 00317 END IF 00318 END IF 00319 IF (PRESENT(tau_g)) THEN 00320 IF (PRESENT(tau_g_valid).or.rho_struct%tau_g_valid) THEN 00321 tau_g => rho_struct%tau_g 00322 ELSE 00323 CALL cp_unimplemented_error(routineP,"to do",error=error) 00324 NULLIFY(tau_g) 00325 END IF 00326 END IF 00327 IF (PRESENT(rho_r_valid)) rho_r_valid=rho_struct%rho_r_valid 00328 IF (PRESENT(rho_g_valid)) rho_g_valid=rho_struct%rho_g_valid 00329 IF (PRESENT(drho_r_valid)) drho_r_valid=rho_struct%drho_r_valid 00330 IF (PRESENT(drho_g_valid)) drho_g_valid=rho_struct%drho_g_valid 00331 IF (PRESENT(tau_r_valid)) tau_r_valid=rho_struct%tau_r_valid 00332 IF (PRESENT(tau_g_valid)) tau_g_valid=rho_struct%tau_g_valid 00333 IF (PRESENT(soft_valid)) soft_valid=rho_struct%soft_valid 00334 IF (PRESENT(rebuild_each)) rebuild_each=rho_struct%rebuild_each 00335 ! give error if not valid? 00336 IF (PRESENT(tot_rho_r)) tot_rho_r => rho_struct%tot_rho_r 00337 END IF 00338 END SUBROUTINE qs_rho_get 00339 00340 END MODULE qs_rho_types 00341
1.7.3